From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- progs/demo/X11/logo/EXAMPLES.LOGO | 70 ++ progs/demo/X11/logo/README | 104 +++ progs/demo/X11/logo/logo.hs | 1345 +++++++++++++++++++++++++++++++++++++ progs/demo/X11/logo/logo.hu | 3 + 4 files changed, 1522 insertions(+) create mode 100644 progs/demo/X11/logo/EXAMPLES.LOGO create mode 100644 progs/demo/X11/logo/README create mode 100644 progs/demo/X11/logo/logo.hs create mode 100644 progs/demo/X11/logo/logo.hu (limited to 'progs/demo/X11/logo') diff --git a/progs/demo/X11/logo/EXAMPLES.LOGO b/progs/demo/X11/logo/EXAMPLES.LOGO new file mode 100644 index 0000000..bb89632 --- /dev/null +++ b/progs/demo/X11/logo/EXAMPLES.LOGO @@ -0,0 +1,70 @@ +(to nth :index :lst + (if (equal :index 1) + then (first :lst) + else (nth (difference :index 1) (butfirst :lst)))) + +(to makelist :begin :end + (fput :begin (if (equal :begin :end) + then [[]] + else (makelist (sum :begin 1) :end)))) + +(to wheel :centerright + [(hideturtle) + (pendown) + (setangle 90) + (setxy :centerright 350) + (repeat 72 times + [(forward 2) + (left 5)])]) + +(to car + [(pendown) + (hideturtle) + (setxy 400 350) + (setangle 90) + (forward 70) + (left 90) + (forward 100) + (right 60) + (forward 80) + (left 60) + (forward 100) + (left 60) + (forward 80) + (right 60) + (forward 70) + (left 90) + (forward 70) + (left 90) + (forward 350) + (wheel 350) + (wheel 150)]) + +(to docar? + [(local "ans) + (print [do you want a car?]) + (make "ans (read)) + (if (equal (first ans) "yes) + then (car) + else [[oh well]])]) + +(to poly :size :angles + [(hideturtle) + (pendown) + (setangle 90) + (repeat :angles times + [(forward :size) + (right (div 360 :angles))])]) + +(make "x (makelist 3 12)) + +(while (less (first x) 12) + [(make "x (butfirst x)) + (print x)]) + +(clean) + +(car) + +(poly 100 5) + diff --git a/progs/demo/X11/logo/README b/progs/demo/X11/logo/README new file mode 100644 index 0000000..b483e2a --- /dev/null +++ b/progs/demo/X11/logo/README @@ -0,0 +1,104 @@ +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: User Manual + + +Control Commands: + + +(DO WHILE ) + + Loop, executing a list of commands, then checking a condition and +looping again if the condition is true. + + +(REPEAT n TIMES) + WHILE cn cl + IF cn THEN cl1 [ELSE cl2] + +Load a file: + USE "filename + +Environment Commands: + MAKE "nm v + LOCAL "nm + TO :nm1 :nm2 :nm3 ... cl + +Text I/O: + PRINT v + READ + +Graphics Commands: + FORWARD n + BACKWARD n + SETXY n1 n2 + LEFT n + RIGHT n + PENUP + PENDOWN + HIDETURTLE + SHOWTURTLE + CLEARSCREEN + CLEAN + +Graphics Functions: + XCOR + YCOR + GETANGLE + GETPEN + GETTURTLE + +Mathematical: + SUM n1 n2 + DIFFERENCE n1 n2 + PRODUCT n1 n2 + MOD n1 n2 + DIV n1 n2 + POWER n1 n2 + +Boolean: + AND b1 b2 + OR b1 b2 + NOT b + +Predicates: + WORDP v + LISTP v + NUMBERP v + GREATER n1 n2 + LESS n1 n2 + EQUAL v1 v2 + +Word/List: + FIRST t + LAST t + FPUT t l + BUTFIRST l + WORD w1 w2 w3 ... + LIST t1 t2 t3 ... + CONCAT l1 l2 + SENTENCE t1 t2 t3 ... + + +Our Logo interpreter will only support one of the three windowing +modes: window mode, where the turtle, if it walks off the end of the +screen, just continues going and does not wrap. The two (unsupported) +modes are fence mode where the turtle cannot walk off the end, and +wrap mode. The initial turtle state will be with the turtle hidden, +the pen down, and the turtle in the center of the screen facing +upwards. + +All input (both for commands as well as user-input) will be +case-insensitive, and the interpreter needs to handle lists, words, +integers, and boolean values. Also, typing "GoodBye" at the LOGO> +prompt exits the interpreter. + +All commands will be enclosed in parentheses, and all lists of +commands will be enclosed in square brackets, so that there is no +longer any need for the keyword "End". Also, all procedures will +return the value of their last command, so that there are no Stop or +Output commands. IF statements should return the value of the last +statement executed, but all looping constructs should return no value. + + diff --git a/progs/demo/X11/logo/logo.hs b/progs/demo/X11/logo/logo.hs new file mode 100644 index 0000000..458eca1 --- /dev/null +++ b/progs/demo/X11/logo/logo.hs @@ -0,0 +1,1345 @@ +{- + +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: LOGO Interpreter + +-} + + + +------------------------------------------------------------------------------- +module REPLoop where + +{- + +REPLoop has two main parts: the first part (function logo) sets up the +graphics window, prints a welcome message, initializes the variable +and procedure environments and the turtle, accepts and lines's the +user input, runs the read-eval-print loop (part two), and then closes +the graphics window and exists; the second part (function repLoop) +lexes and parses each command, prints an error message if there was a +syntax error and evaluates (or tries to) if there wasn't, and then +either prints the value or an error message or exits if the value +returnd by the evaluator is "GoodBye". + +-} + +import Lexer +import Parser +import Evaluator +import Xlib + +demo = main + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $ + logo host + +logo :: String -> IO () + +logo host = + xOpenDisplay host `thenIO` \ display -> + + let (screen:_) = xDisplayRoots display + fg_color = xScreenWhitePixel screen + bg_color = xScreenBlackPixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 100 100 500 500) + [XWinBackground bg_color, + XWinBackingStore XAlwaysBackStore] + `thenIO` \ graphWindow -> + xSetWmName graphWindow "Logo" `thenIO` \ () -> + xSetWmIconName graphWindow "Logo" `thenIO` \ () -> + xMapWindow graphWindow `thenIO` \ () -> + + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ graphContext -> + + xDisplayForceOutput display `thenIO` \ () -> + + appendChan stdout ("Welcome to LOGO!\n" ++ prompt) exit $ + readChan stdin exit $ \userInput -> + repLoop + (varEnvsInit,procEnvsInit,turtleInit) + ((lines userInput,Lexer), + (graphWindow,display,graphContext,bg_color,fg_color)) $ + xCloseDisplay display + +-- Initial Environments -- + +varEnvsInit :: VarsType +varEnvsInit = [[("GOODBYE",GoodBye)]] + +-- all user-defined commands must have dummy entries +procEnvsInit :: ProcsType +procEnvsInit = (map (makeFakeProc) + [("XCOR",0),("YCOR",0),("GETANGLE",0),("GETPEN",0), + ("GETTURTLE",0), + ("SUM",2),("DIFFERENCE",2),("PRODUCT",2),("MOD",2), + ("DIV",2),("POWER",2), + ("AND",2),("OR",2),("NOT",1), + ("WORDP",1),("LISTP",1),("NUMBERP",1),("GREATER",2), + ("EQUAL",2),("LESS",2), + ("BUTFIRST",1),("FPUT",2),("CONCAT",2), + ("FIRST",1),("LAST",1),("WORD",-2),("LIST",-2), + ("SENTENCE",-2), ("USE",1)]):[] + +turtleInit :: TurtleType +turtleInit = (500 `div` 2,500 `div` 2,90,True,False) + +-- makes a dummy procedure +makeFakeProc :: (NameType , Int) -> (NameType , ProcType) +makeFakeProc (name,num) = (name,(makeArgs num,[])) + +makeArgs :: Int -> [NameType] +makeArgs n | n > 0 = "" : makeArgs (n-1) + | otherwise = [] + +-- keep running Read-Eval-Print Loop until user types GoodBye +-- repLoop keeps running until user types "GoodBye", alternately +-- lexing, parsing, and evaluating each command +-- after a syntax error, the lex state is reset +repLoop :: EnvsType -> StateType -> IO () -> IO () +repLoop e1 (inS1,gs1) end = + let fail1 msg (is1,ls1) = errorOutput msg $ + repLoop e1 ((is1,Lexer),gs1) end + -- parser fail continuation doesn't contain graphics state + fail2 msg ((is2,ls2),gs2) = errorOutput msg $ + repLoop e1 ((is2,Lexer),gs1) end + -- evaluator fail continuation does contain graphics state + in + parse [] inS1 fail1 $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail2 $ \v e2 ((is3,ls3),gs3) -> + output v end $ + repLoop e2 ((is3,Lexer),gs3) end + else + fail1 "Syntax error: expected end of line" inS2 + -- repLoop will still be rerun + +-- print error message +errorOutput :: String -> IO () -> IO () +errorOutput error = appendChan stdout (error ++ prompt) abort + +-- print expression value, exiting if GoodBye +output :: Value -> IO () -> IO () -> IO () +output GoodBye end succ + = appendChan stdout "\nGoodbye!\n"abort end +output v end succ + = appendChan stdout ((valueToString v) ++ prompt) abort succ + +prompt :: String +prompt = "\nLOGO> " + + + +------------------------------------------------------------------------------- +module Evaluator where + +{- + +Evaluator takes an Abstract Syntax Tree and evaluates it in the +current environment, returning both the resultant value and the new +environment (as well as the updated state, of which only the user +input can actually be changed in the evaluator). + +A value can be of one of six types: integer, string, list, and +boolean, as well as null (for commands which don't return anything and +newly-declared local variables), and goodbye, which allows logo to +quit. + +The environment consists of three parts. The variable environment and +the procedure environment are separate (so that a name can refer both +to a variable and a procedure: Logo syntax is such that there is +never any ambiguity) are both lists of name-value association lists. +Each association list representes a "local environment", with each +successive one being more "global", so that the last environment in +the list is the global environment. Local environments are produced +by user-function invocations and removed at the end of those +invocations. + +-} + +import Lexer +import Parser +import Xlib + +type NameType = [Char] +type WordType = [Char] +type Error = [Char] + +type StateType = (InputState , GraphicsState) +type GraphicsState = (XWindow , XDisplay , XGcontext , XPixel , XPixel) +type EnvsType = (VarsType,ProcsType,TurtleType) +type VarsType = [[(NameType , Value)]] +type ProcsType = [[(NameType , ProcType)]] +type TurtleType = (Int , Int , Int , Bool , Bool) +type ProcType = ([NameType] , ClauseType) + +data Value = Null + | Num Int + | Word WordType + | List ListType + | Boolean Bool + | GoodBye + deriving Text + +data ListType = NullList | Value :* ListType + deriving Text + + +type EvalFailType = Error -> StateType -> IO () +type EvalSuccType = Value -> EnvsType -> StateType -> IO () +type EvalResType = StateType -> EvalFailType -> EvalSuccType -> IO () +type EvaluateType = EnvsType -> AST -> EvalResType + + +evaluate :: EvaluateType + +evaluate (vs,p:ps,ttl) (To newName newProc) ss fail succ + = succ Null (vs,((newName,newProc):p):ps,ttl) ss + -- procedures + +evaluate e (Read) ((i:is,ls),gs) fail succ + = succ (List (makeReadList (lexerReadLine i))) e ((is,ls),gs) + -- user input + +evaluate e1 (Print [a]) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + appendChan stdout ((valueToString v)++"\n") abort $ + succ Null e2 ss2 + -- user output + +evaluate e (Argument (Val (Word n))) ss fail succ + = lookup e n ss fail $ \v -> + succ v e ss + -- variable reference + +evaluate e (Argument (Val v)) ss fail succ + = succ v e ss + -- constant + +evaluate e (Argument (QuotedWordArg n)) ss fail succ + = succ (Word n) e ss + -- string constant + +evaluate (v:vs,ps,ttl) (Local n) ss fail succ + = succ Null (((n,Null):v):vs,ps,ttl) ss + -- local variable declaraion + -- local returns null, and sets the new local variable to null also + +evaluate e (ParseList l) ss fail succ + = succ (List l) e ss + -- lists (also constant) + +evaluate e (Loop l cond insts) ss fail succ + = evalLoop l e cond insts ss fail succ + -- loops + +evaluate e (If cond thens elses) ss fail succ + = evalIf e cond thens elses ss fail succ + -- if-then[-eles] conditionals + +evaluate e1 (Command name as1) ss fail succ + | ((na == length as1) || (na == -2)) + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + apply name as2 e2 ss2 fail $ \v e3 ss3 -> + succ v e3 ss3 + | na == -1 + = fail ("Function does not exist: " ++ name) ss + | otherwise + = fail ("Wrong number of arguments to " ++ name) ss + where na = numArgs e1 name + -- function applications + +evaluate e1 (Make n a) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + update e2 n v $ \e3 -> + succ v e3 ss2 + -- assignment statements, which return the assigned value + +evaluate e1 (Graphics name as1) ss fail succ + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + doGraphics name as2 e2 ss2 fail $ \e3 ss3 -> + succ Null e3 ss3 + -- side-effecting graphics statements, which all return null +-- end evaluate + + +-- evaluate a list of actual parameters, returning the corresponding +-- list of values +evalArgs :: EnvsType -> ParseArgs -> StateType -> EvalFailType -> + (EnvsType -> EvalArgs -> StateType -> IO ()) -> IO () +evalArgs e [] ss fail succ + = succ e [] ss +evalArgs e1 (a:as1) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalArgs e2 as1 ss2 fail $ \e3 as2 ss3 -> + succ e3 (v:as2) ss3 + + +-- evaluate a list of commands, returning the value of the last one +evalClause :: EnvsType -> ClauseType -> EvalResType +evalClause e [] ss fail succ + = succ Null e ss +evalClause e (a:[]) ss fail succ + = evaluate e a ss fail succ +evalClause e1 (a:as) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalClause e2 as ss2 fail succ + +-- convert a lexed user-input list to a list constant +makeReadList :: [WordType] -> ListType +makeReadList [] = NullList +makeReadList (w:ws) = (Word w) :* (makeReadList ws) + + +-- Variable routines -- + +-- look up a variable reference in the variable environment +-- search the most-local environments first +-- return an error if not found +lookup :: EnvsType -> NameType -> StateType -> EvalFailType -> + (Value -> IO ()) -> IO () +lookup ([],ps,ttl) name ss fail succ + = fail ("Unbound variable: " ++ name) ss +lookup ([]:vss,ps,ttl) name ss fail succ + = lookup (vss,ps,ttl) name ss fail succ +lookup (((n,v):vs):vss,ps,ttl) name ss fail succ + | n == name = succ v + | otherwise = lookup (vs:vss,ps,ttl) name ss fail succ + +-- update the variable environment +-- replace the most-local occurrance first; if none are found, +-- create a new variable and place it in the most-global environment +update :: EnvsType -> NameType -> Value -> (EnvsType -> IO ()) -> IO () +update ([]:[],ps,ttl) name value succ + = succ (((name,value):[]):[],ps,ttl) +update ([]:vss,ps,ttl) name value succ + = update (vss,ps,ttl) name value $ \(vss2,ps2,ttl2) -> + succ ([]:vss2,ps2,ttl2) +update (((n,v):vs):vss,ps,ttl) name value succ + | n == name = succ (((n,value):vs):vss,ps,ttl) + | otherwise = update (vs:vss,ps,ttl) name value $ \(vs2:vss2,ps2,ttl2) -> + succ (((n,v):vs2):vss2,ps2,ttl2) + + +-- Control structures -- + +-- evaluate loops +evalLoop :: LoopType -> EnvsType -> ConditionType -> ClauseType -> + EvalResType +evalLoop Do = evalDo +evalLoop While = evalWhile +evalLoop Repeat = evalRepeat + +-- evaluate while statements +-- loop semantics: evaluate condition; if true, evaluate clause, then loop +-- while returns null +evalWhile :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalWhile e1 cond insts ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then + evalClause e2 insts ss2 fail $ \v e3 ss3 -> + evalWhile e3 cond insts ss3 fail succ + else + succ Null e2 ss2 + +-- evaluate do-while statements +-- loop semantics: evaluate clause then evaluate condition; if true, loop +evalDo :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalDo e1 cond insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + evalCond e2 cond ss2 fail $ \b e3 ss3 -> + if b + then + evalDo e3 cond insts ss3 fail succ + else + succ Null e3 ss3 + +-- evaluate repeat statements +-- loop semantics: evaluate loop number as n; evaluate clause n times +-- evaluate loop number and print error if it is negative or not an integer +evalRepeat :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalRepeat e1 cond insts ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Num n -> if (n >= 0) + then doIterations e2 n insts ss2 fail succ + else fail "Repeat: Iteration count cannot be negative" ss2 + otherwise -> fail "Repeat: Invalid iteration count" ss2 + +-- perform loop interations: evaluate "insts" "n" times +doIterations :: EnvsType -> Int -> ClauseType -> EvalResType +doIterations e 0 insts ss fail succ + = succ Null e ss +doIterations e1 (n+1) insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + doIterations e2 n insts ss2 fail succ + +-- evaluates conditions and returns either true, false, or an error +evalCond :: EnvsType -> ConditionType -> StateType -> EvalFailType -> + (Bool -> EnvsType -> StateType -> IO ()) -> IO () +evalCond e1 cond ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Boolean b -> succ b e2 ss2 + otherwise -> fail "Invalid condition" ss2 + +-- evaluate if-then[-else] statements +evalIf :: EnvsType -> ConditionType -> ClauseType -> ClauseType -> EvalResType +evalIf e1 cond thens elses ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then evalClause e2 thens ss2 fail succ + else evalClause e2 elses ss2 fail succ + + +-- Function application -- + +-- returns the number of arguments to a user-defined or built-in function +-- -1 means the function wasn't found +-- -2 means the function can take any number of arguments +numArgs :: EnvsType -> CommandName -> Int +numArgs (vs,[],ttl) name + = -1 +numArgs (vs,[]:pss,ttl) name + = numArgs (vs,pss,ttl) name +numArgs (vs,((n,(formals,body)):ps):pss,ttl) name + | inList ["WORD","SENTENCE","LIST"] name = -2 + | n == name = length formals + | otherwise = numArgs (vs,ps:pss,ttl) name + +-- apply a function to its arguments +-- mostly just decides if it's user-defined or built-in, then dispatches +apply :: CommandName -> EvalArgs -> EnvsType -> EvalResType +apply n as e ss fail succ + | isBuiltIn n = applyPrimProc n as e ss fail succ + | otherwise = applyUserProc (getProc e n) as e ss fail succ + + + +-- returns procedure "name" from the procedure environment +-- searches most-local environments first +-- precondition: procedure does exist somewhere +getProc :: EnvsType -> CommandName -> ProcType +getProc (vss,[]:pss,ttl) name + = getProc (vss,pss,ttl) name +getProc (vs,((n,p):ps):pss,ttl) name + | n == name = p + | otherwise = getProc (vs,ps:pss,ttl) name + +-- apply user function: +-- bind formal parameters +-- create local enviroments +-- evaluate body of function +-- destroy local environments +-- return value of body +applyUserProc :: ProcType -> EvalArgs -> EnvsType -> EvalResType +applyUserProc (formals,body) actuals e1 ss fail succ + = bind formals actuals e1 $ \e2 -> + evalClause e2 body ss fail $ \v (vs:vss,ps:pss,ts) ss2 -> + succ v (vss,pss,ts) ss2 + +-- bind formal parameters to actuals in local environment +bind :: [NameType] -> EvalArgs -> EnvsType -> (EnvsType -> IO ()) -> IO () +bind formals actuals (vss,pss,ttl) succ + = succ ((zip formals actuals):vss,[]:pss,ttl) + + +-- Built-in functions -- + +-- returns true for built-in functions +isBuiltIn :: CommandName -> Bool +isBuiltIn = inList ["XCOR","YCOR","GETANGLE","GETPEN","GETTURTLE", + "SUM","DIFFERENCE","PRODUCT","MOD","DIV","POWER", + "AND","OR","NOT", + "WORDP","LISTP","NUMBERP","GREATER","EQUAL","LESS", + "BUTFIRST","FPUT","CONCAT", + "FIRST","LAST","WORD","LIST","SENTENCE", "USE"] + + +-- applies a built-in function to its arguments +applyPrimProc :: CommandName -> [Value] -> EnvsType -> EvalResType + +applyPrimProc "XCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num x) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "YCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num y) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETANGLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num a) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETPEN" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean p) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean t) (vs,ps,(x,y,a,p,t)) ss + +applyPrimProc "SUM" [Num a , Num b] e ss fail succ + = succ (Num (a+b)) e ss +applyPrimProc "DIFFERENCE" [Num a , Num b] e ss fail succ + = succ (Num (a-b)) e ss +applyPrimProc "PRODUCT" [Num a , Num b] e ss fail succ + = succ (Num (a*b)) e ss +applyPrimProc "MOD" [Num a , Num b] e ss fail succ + = succ (Num (a `mod` b)) e ss +applyPrimProc "DIV" [Num a , Num b] e ss fail succ + = succ (Num (a `div` b)) e ss +applyPrimProc "POWER" [Num a , Num b] e ss fail succ + | b >= 0 = succ (Num (a^b)) e ss + | otherwise = fail ("Negative exponent: " ++ (show b)) ss + +applyPrimProc "AND" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a && b)) e ss +applyPrimProc "OR" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a || b)) e ss +applyPrimProc "NOT" [Boolean a] e ss fail succ + = succ (Boolean (not a)) e ss + +applyPrimProc "WORDP" [Word w] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "WORDP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "NUMBERP" [Num n] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "NUMBERP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "LISTP" [List l] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "LISTP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "GREATER" [Num a , Num b] e ss fail succ + = succ (Boolean (a > b)) e ss +applyPrimProc "EQUAL" [Num a , Num b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Word a , Word b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "LESS" [Num a , Num b] e ss fail succ + = succ (Boolean (a < b)) e ss + +applyPrimProc "BUTFIRST" [Word ""] e ss fail succ + = succ (Word "") e ss +applyPrimProc "BUTFIRST" [Word (c:cs)] e ss fail succ + = succ (Word cs) e ss +applyPrimProc "BUTFIRST" [List NullList] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "BUTFIRST" [List (v :* vs)] e ss fail succ + = succ (List vs) e ss +applyPrimProc "FPUT" [v , List l] e ss fail succ + = succ (List (v :* l)) e ss +applyPrimProc "CONCAT" [List l1 , List l2] e ss fail succ + = succ (List (listConcatenate l1 l2)) e ss +applyPrimProc "FIRST" [Word (c:cs)] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "FIRST" [List (v :* vs)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [Word (c:[])] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "LAST" [Word ""] e ss fail succ + = succ Null e ss +applyPrimProc "LAST" [Word (c:cs)] e ss fail succ + = applyPrimProc "LAST" [(Word cs)] e ss fail succ +applyPrimProc "LAST" [List (v :* NullList)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [List (v :* vs)] e ss fail succ + = applyPrimProc "LAST" [(List vs)] e ss fail succ +applyPrimProc "WORD" [] e ss fail succ + = succ (Word "") e ss +applyPrimProc "WORD" ((Word w):ws) e ss fail succ + = applyPrimProc "WORD" ws e ss fail $ \(Word wsc) e2 ss2 -> + succ (Word (w ++ wsc)) e2 ss2 +applyPrimProc "LIST" (v:vs) e ss fail succ + = applyPrimProc "LIST" vs e ss fail $ \(List l) e2 ss2 -> + succ (List (v :* l)) e2 ss2 +applyPrimProc "LIST" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" ((List l):[]) e ss fail succ + = succ (List l) e ss +applyPrimProc "SENTENCE" ((List l):vs) e ss fail succ + = applyPrimProc "SENTENCE" [List l] e ss fail $ \(List s1) e2 ss2 -> + applyPrimProc "SENTENCE" vs e2 ss2 fail $ \(List s2) e3 ss3 -> + succ (List (listConcatenate s1 s2)) e3 ss3 +applyPrimProc "SENTENCE" (v:vs) e ss fail succ + = applyPrimProc "SENTENCE" vs e ss fail $ \(List ws) e2 ss2 -> + succ (List (v :* ws)) e2 ss2 + +applyPrimProc "USE" [Word filename] + e + ss@((ins, ls), gs) + fail succ + = readFile filename (\ _ -> fail ("Can't read file: " ++ filename) ss) + $ \filecontents -> + useRepLoop e ((lines filecontents, Lexer), gs) + (\ msg s -> fail msg ss) $ \ v e s -> + succ v e ss + +applyPrimProc n _ _ ss fail _ + = fail ("Incorrect arguments: " ++ n) ss + +useRepLoop :: EnvsType -> EvalResType +useRepLoop e s@(([], ls), gs) fail succ = succ (Word "OK") e s +useRepLoop e1 s1@(inS1,gs1) fail succ = + parse [] inS1 (\ msg ins -> fail msg (ins, gs1)) $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail $ \v e2 s3 -> + useRepLoop e2 s3 fail succ + else + fail "Syntax error: expected end of line" (inS2, gs1) + + + +-- concatenates two lists +listConcatenate :: ListType -> ListType -> ListType +listConcatenate NullList l2 = l2 +listConcatenate (v :* l1) l2 = (v :* (listConcatenate l1 l2)) + + +-- Graphics -- + +type EvalArgs = [Value] +type GraphEnv = (Int,Int,Int,Bool) + +-- evaluates side-effecting graphics functions +-- note: none of them return values +doGraphics :: CommandName -> EvalArgs -> EnvsType -> StateType -> + EvalFailType -> (EnvsType -> StateType -> IO ()) -> IO () + +doGraphics "HIDETURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = hideTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,False)) ss + -- hide turtle, appropriately adjust environment + +doGraphics "SHOWTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = showTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,True)) ss + -- show turtle, appropriately adjust environment + +doGraphics name as (vs,ps,(x,y,a,p,True)) ss fail succ + = hideTurtle x y a ss $ + moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + showTurtle x2 y2 a2 ss $ + succ (vs,ps,(x2,y2,a2,p2,True)) ss + -- executes graphics commands if turtle is shownn + +doGraphics name as (vs,ps,(x,y,a,p,False)) ss fail succ + = moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + succ (vs,ps,(x2,y2,a2,p2,False)) ss + -- executes graphics commands if turtle is not shown + +-- converts an integer to a float +toFloat :: Int -> Float +toFloat = fromInteger . toInteger + +newmod a b = let c = a `mod` b + in if (c < 0) then (c + b) else c + +-- shows the turtle, but returns nothing +showTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = let dx1 = round (12 * cos (toFloat a * pi/180)) + dx2 = round (4 * sin (toFloat a * pi/180)) + dy1 = round (12 * sin (toFloat a * pi/180)) + dy2 = round (4 * cos (toFloat a * pi/180)) + in + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDisplayForceOutput display + `thenIO_` + succ + +-- hides the turtle, but returns nothing +hideTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +hideTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = xUpdateGcontext graphContext [XGCForeground bg] + `thenIO_` + (showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) $ + (xUpdateGcontext graphContext [XGCForeground fg] + `thenIO_` + succ)) + +-- performs all graphics commands that don't involve hiding/showing +-- the turtle +moveTurtle :: CommandName -> EvalArgs -> GraphEnv -> StateType -> + (GraphEnv -> IO ()) -> IO () +moveTurtle "SETXY" [Num xp,Num yp] (x,y,a,p) ss succ + = succ (xp,yp,a,p) + +-- move the turtle forward "d" times, drawing a line if pen is down +moveTurtle "FORWARD" [Num d] (x,y,a,p) + (is,(graphWindow,display,graphContext,fg,bg)) succ + = let xp = x + round (toFloat d * cos (toFloat a * pi/180)) + yp = y - round (toFloat d * sin (toFloat a * pi/180)) in + (if p + then (xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint xp yp)) + else returnIO ()) `thenIO` \ () -> + xDisplayForceOutput display `thenIO` \ () -> + succ (xp,yp,a,p) + +-- move the turtle backward "d" pixels, drawing a line if pen is down +moveTurtle "BACKWARD" [Num d] (x,y,a,p) ss succ + = moveTurtle "FORWARD" [Num (-d)] (x,y,a,p) ss succ + +-- rotate turtle to "ap" degrees from facing due east +moveTurtle "SETANGLE" [Num ap] (x,y,a,p) ss succ + = succ (x,y,ap,p) + +-- rotate turtle counterclockwise "ap" degrees +moveTurtle "LEFT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a + ap) `newmod` 360 ,p) + +-- rotate turtle clockwise "ap" degrees +moveTurtle "RIGHT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a - ap) `newmod` 360 ,p) + +-- pick pen up +moveTurtle "PENUP" [] (x,y,a,p) ss succ + = succ (x,y,a,False) + +-- put pen down +moveTurtle "PENDOWN" [] (x,y,a,p) ss succ + = succ (x,y,a,True) + +-- clear screen but don't otherwise alter turtle state +moveTurtle "CLEARSCREEN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (x,y,a,p) + +-- pick pen up and reset turtle +moveTurtle "CLEAN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (500 `div` 2,500 `div` 2,90,True) + +-- do nothing if arguments are incorrect +moveTurtle _ _ e _ succ = succ e + + +-- valueToString, etc. -- + +-- convert a value to a string +valueToString :: Value -> String +valueToString (Word w) = w +valueToString (Num n) = show n +valueToString (Boolean True) = "TRUE" +valueToString (Boolean False) = "FALSE" +valueToString Null = "" +valueToString (List l) = "[" ++ (listToString l) ++ "]" +valueToString GoodBye = "Don't play around with this variable!" + +-- convert a list to a string +listToString :: ListType -> String +listToString NullList = "" +listToString (v :* NullList) = valueToString v +listToString (v :* l) = (valueToString v) ++ " " ++ (listToString l) + + + +------------------------------------------------------------------------------- +module Lexer where + +{- + +Lexer takes as input a line from standard input and returns an ordered +pair containing the translation of that list into tokens as well as +the current state of the lexer (how many parentheses and brackets are +still open). The state is necessary because some commands may take +multiple lines, so a bracket (say) may be left open on one line to be +closed later on. + +All unmatched close brackets and parentheses are treated as spaces +(and therefore ignored). + +The method for tokenizing commands is: + + All words are delimited by spaces, parenthesis, or brackets. + + All words beginning with a double quote are returned as quoted words + rather than normal words. + + Any character preceded by a backslash is taken as is, rather than + tokenized normally. + + All words are translated to upper case.. + +The method for tokenizing user input is: + + All words are delimited by spaces and translated to upper case. + +-} + +import Parser +import Evaluator + + +data LexState = Lexer | LexerBracket Int LexState | LexerParen Int LexState + deriving Text + +type LexerType = [Char] -> ([Token] , LexState) + +data Token = OpenBracket + | CloseBracket + | OpenParen + | CloseParen + | QuotedWord WordType + | Normal WordType deriving (Text,Eq) + + +-- call appropriate lex procedure depending upon the current lex state +lexDispatch :: LexState -> LexerType +lexDispatch (Lexer) = lexer +lexDispatch (LexerBracket n s) = lexerBracket n s +lexDispatch (LexerParen n s) = lexerParen n s + + +-- handle commands +lexer :: LexerType +lexer [] = ([] , Lexer) +lexer (' ':cs) = lexer cs +lexer ('[':cs) = let (ts , s) = lexerBracket 1 (Lexer) cs + in (OpenBracket : ts , s) +lexer ('(':cs) = let (ts , s) = lexerParen 1 (Lexer) cs + in (OpenParen : ts , s) +lexer (')':cs) = lexer cs +lexer (']':cs) = lexer cs +lexer ('"':cs) = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((QuotedWord (upWord t)):ts , s) +lexer cs = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((Normal (upWord t)):ts , s) + +lexerWord :: (Char -> Bool) -> [Char] -> (WordType , [Char]) +lexerWord endCond [] + = ([] , []) +lexerWord endCond (c:cs) + | c == '\\' = if cs == [] + then ("\\" , cs) + else + let (t , cs2) = lexerWord endCond (tail cs) + in ((head cs):t , cs2) + | endCond c = ([] , (c:cs)) + | otherwise = let (t , cs2) = lexerWord endCond cs + in ((toUpper c):t , cs2) + + +-- performs lexing inside brackets +lexerBracket :: Int -> LexState -> LexerType +lexerBracket n s [] + = ([] , LexerBracket n s) +lexerBracket n s (' ':cs) + = lexerBracket n s cs +lexerBracket 1 s (']':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseBracket:ts , s2) +lexerBracket n s (']':cs) + = let (ts , s2) = lexerBracket (n-1) s cs + in (CloseBracket:ts , s2) +lexerBracket n s ('[':cs) + = let (ts , s2) = lexerBracket (n+1) s cs + in (OpenBracket:ts , s2) +lexerBracket n s ('(':cs) + = let (ts , s2) = lexerParen 1 (LexerBracket n s) cs + in (OpenParen:ts , s2) +lexerBracket n s (')':cs) + = lexerBracket n s cs +lexerBracket n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerBracket n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- performs lexing inside parentheses +lexerParen :: Int -> LexState -> LexerType +lexerParen n s [] + = ([] , LexerParen n s) +lexerParen n s (' ':cs) + = lexerParen n s cs +lexerParen 1 s (')':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseParen:ts , s2) +lexerParen n s (')':cs) + = let (ts , s2) = lexerParen (n-1) s cs + in (CloseParen:ts , s2) +lexerParen n s ('(':cs) + = let (ts , s2) = lexerParen (n+1) s cs + in (OpenParen:ts , s2) +lexerParen n s ('[':cs) + = let (ts , s2) = lexerBracket 1 (LexerParen n s) cs + in (OpenBracket:ts , s2) +lexerParen n s (']':cs) + = lexerParen n s cs +lexerParen n s ('"':cs) + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((QuotedWord (upWord t)):ts , s2) +lexerParen n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- returns true for delimiters +isDelimiter :: Char -> Bool +isDelimiter = inList " []()" + +-- returns true of p is in cs +inList :: (Eq a) => [a] -> a -> Bool +inList [] p = False +inList (c:cs) p = (c == p) || (inList cs p) + + +-- handle user input +lexerReadLine :: [Char] -> [WordType] +lexerReadLine [] + = [] +lexerReadLine (' ':cs) + = lexerReadLine cs +lexerReadLine cs + = let (firstWord,restOfWords) = span (/= ' ') cs + in (upWord firstWord) : lexerReadLine restOfWords + +-- translate a word to upper case +upWord :: WordType -> WordType +upWord = map (toUpper) + + + +------------------------------------------------------------------------------- +module Parser where + +{- + +Parser takes a list of tokens, the input state, and fail and success +continuations and returns an Abstract Syntax Tree, the remaining +tokens (hopefully none), and the new input state. The input state +will be changed every time Parser runs out of tokens: it simply grabs +(and lexes) the next line of user-input. It therefore doesn't return +anything until the entire AST has been be read in, even if it spans +several lines, though parse may catch some errors before all lines +have been input. In this case, it ceases taking input and returns the +error. + +An Abstract Syntax Tree represents one command, and breaks those +commands into Ifs, Loops, Tos, Locals, Makes, Reads, Prints, +Constants, List constants, Graphics commands (which produce +side-effects), and function applications. All built-in commands that +don't fit into one of those categories are lumped into function +applications along with user-defined functions. Each type of AST is +parsed into subcommands, subclauses (lists of commands), command +arguments (also subcommands), and any other values that will be +immediately-evaluatable (such as function names). + +-} + + +import Lexer +import Evaluator + + +type CommandName = [Char] +type ClauseType = [AST] +type ConditionType = AST + +type ParseArgs = [AST] + +data ArgType = Val Value | QuotedWordArg WordType + deriving Text + +data AST = ParseList ListType + | If ConditionType ClauseType ClauseType + | Loop LoopType ConditionType ClauseType + | To NameType ProcType + | Make NameType AST + | Local NameType + | Read + | Print ParseArgs + | Argument ArgType + | Graphics CommandName ParseArgs + | Command CommandName ParseArgs deriving Text + +data LoopType = Do | While | Repeat + deriving Text + +type ParseFailType = Error -> InputState -> IO () +type ParseType = [Token] -> InputState -> ParseFailType -> + (AST -> [Token] -> InputState -> IO ()) -> IO () +type ParseClauseType = [Token] -> InputState -> ParseFailType -> + (ClauseType -> [Token] -> InputState -> IO ()) -> IO () + +type InputState = ([[Char]] , LexState) + +parse :: ParseType + +parse [] (i:is , ls) fail succ + = let (ts , ls2) = lexDispatch ls i + in parse ts (is , ls2) fail succ + +parse ((QuotedWord s) : ts) inS fail succ + = succ (Argument (QuotedWordArg s)) ts inS + +parse ((Normal s) : ts) inS fail succ + = succ (Argument (Val (process s))) ts inS + +parse (OpenParen : []) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parse (OpenParen:ts) (is,ls2) fail succ + +parse (OpenParen : (Normal t) : ts) inS fail succ + | t == "TO" = makeProc ts inS fail succ + | t == "MAKE" = makeMake ts inS fail succ + | t == "LOCAL" = makeLocal ts inS fail succ + | t == "READ" = makeRead ts inS fail succ + | t == "PRINT" = makePrint ts inS fail succ + | t == "IF" = makeIf ts inS fail succ + | isLoop t = makeLoop t ts inS fail succ + | isGraphics t = makeGraphics t ts inS fail succ + | otherwise = makeCommand t ts inS fail succ + +parse (OpenBracket : ts) inS fail succ + = parseList ts inS fail succ + +parse ts inS@([], _) _ succ = succ (Argument (Val (Word "GOODBYE"))) ts inS + +parse _ inS fail _ + = fail "Syntax error" inS + + +-- returns true for all loop names +isLoop :: CommandName -> Bool +isLoop = inList ["DO","WHILE","REPEAT"] + +-- returns true for all side-effecting graphics command names +isGraphics :: CommandName -> Bool +isGraphics = inList ["FORWARD","BACKWARD","LEFT","RIGHT", + "SETXY","SETANGLE","PENUP","PENDOWN", + "HIDETURTLE","SHOWTURTLE","CLEARSCREEN","CLEAN"] + +-- Parse lists -- + +-- parses a list constant +parseList :: ParseType +parseList [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseList ts (is,ls2) fail succ +parseList (CloseBracket:ts) inS fail succ + = succ (ParseList NullList) ts inS +parseList (OpenBracket:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l1) ts2 inS2 -> + parseList ts2 inS2 fail $ \(ParseList l2) ts3 inS3 -> + succ (ParseList ((List l1) :* l2)) ts3 inS3 +parseList ((Normal w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((process w) :* l)) ts2 inS2 +parseList (OpenParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word "(") :* l)) ts2 inS2 +parseList (CloseParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word ")") :* l)) ts2 inS2 +parseList ((QuotedWord w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word w) :* l)) ts2 inS2 + + +-- parses constant values, distinguishing words from integers and booleans +process :: WordType -> Value +process "TRUE" = Boolean True +process "FALSE" = Boolean False +process ('-':w) + | all isDigit w = Num (- (stringToNum (reverse w))) + | otherwise = Word ('-':w) +process w + | all isDigit w = Num (stringToNum (reverse w)) + | otherwise = Word w + +-- converts a string to a positive integer +stringToNum :: String -> Int +stringToNum (d:[]) = charToDigit d +stringToNum (d:ds) = (charToDigit d) + 10 * stringToNum ds + +-- converts a character to a digit +charToDigit :: Char -> Int +charToDigit c = ord c - ord '0' + + +-- Parse command statements -- + +-- parses commands +-- format: ( ...) +makeCommand :: CommandName -> ParseType +makeCommand n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Command n as) ts2 inS2 + + +-- parses a list of commands that are terminated by token "term"" +parseArgs :: Token -> ParseClauseType +parseArgs term [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseArgs term ts (is,ls2) fail succ +parseArgs term (t:ts) inS fail succ + | t == term = succ [] ts inS + | otherwise = parse (t:ts) inS fail $ \a ts2 inS2 -> + parseArgs term ts2 inS2 fail $ \as ts3 inS3 -> + succ (a:as) ts3 inS3 + + +-- Parse I/O statements -- + +-- parses read statements +-- format: (READ) +makeRead :: ParseType +makeRead (CloseParen:ts) inS fail succ + = succ Read ts inS +makeRead _ inS fail _ + = fail "Read: too many arguments" inS + +-- parses print statements +-- format: (PRINT ) +makePrint :: ParseType +makePrint ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + if (length as) == 1 + then succ (Print as) ts2 inS2 + else fail "Print: too many arguments" inS + + + +-- Parse TO statements -- + + +-- parses to statements +-- format: (TO ... ) +-- note: all formal parameter names must begin with a colon +makeProc :: ParseType +makeProc [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeProc ts (is,ls2) fail succ +makeProc ((Normal t):ts) inS fail succ + = parseFormals ts inS fail $ \p ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (To t p) ts3 inS3 +makeProc _ inS fail _ + = fail "Invalid procedure name" inS + +-- parses the formal parameters +-- takes all words beginning with a colon, and assumes everything +-- after that is part of the body +parseFormals :: [Token] -> InputState -> ParseFailType -> + (([NameType] , ClauseType) -> [Token] -> InputState -> IO ()) + -> IO () +parseFormals [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseFormals ts (is,ls2) fail succ +parseFormals (OpenBracket:ts) inS fail succ + = parseClause (OpenBracket:ts) inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 +parseFormals ((Normal (':':c:cs)):ts) inS fail succ + = parseFormals ts inS fail $ \(formals,pb) ts2 inS2 -> + succ ((':':c:cs):formals , pb) ts2 inS2 +parseFormals ts inS fail succ + = parseClause ts inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 + + +-- Parse MAKE statements -- + +-- parses make statements +-- format: (MAKE ) +-- note: must be quoted +makeMake :: ParseType +makeMake [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeMake ts (is,ls2) fail succ +makeMake ((QuotedWord s):ts) inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (Make s a) ts3 inS3 +makeMake _ inS fail _ + = fail "Make: Improper variable name" inS + + +-- Parse LOCAL statements -- + +-- parses local statements +-- format: (LOCAL ) +-- note: must be quoted +makeLocal :: ParseType +makeLocal [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal ts (is,ls2) fail succ +makeLocal (t:[]) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal (t:ts) (is,ls2) fail succ +makeLocal ((QuotedWord s):CloseParen:ts) inS fail succ + = succ (Local s) ts inS +makeLocal _ inS fail _ + = fail "Local: improper variable name" inS + + +-- Parse IF statements -- + +-- parses if-then and if-then-else statements +-- format: (IF then [else ]) +makeIf :: ParseType +makeIf [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeIf ts (is,ls2) fail succ +makeIf ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseThen ts2 inS2 fail $ \thens elses ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (If cond thens elses) ts4 inS4 + + +-- parses then clauses +parseThen :: [Token] -> InputState -> ParseFailType -> + (ClauseType -> ClauseType -> [Token] -> InputState -> IO ()) -> + IO () +parseThen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseThen ts (is,ls2) fail succ +parseThen ((Normal "THEN"):ts) inS fail succ + = parseClause ts inS fail $ \thens ts2 inS2 -> + parseElse ts2 inS2 fail $ \elses ts3 inS3 -> + succ thens elses ts3 inS3 +parseThen _ inS fail _ + = fail "IF: improper THEN clause" inS + +-- parses (optional) else clauses +parseElse :: ParseClauseType +parseElse [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseElse ts (is,ls2) fail succ +parseElse (CloseParen:ts) inS fail succ + = succ [] (CloseParen:ts) inS +parseElse ((Normal "ELSE"):ts) inS fail succ + = parseClause ts inS fail succ +parseElse _ inS fail _ + = fail "IF: improper ELSE clause" inS + +-- parses clauses +-- a clause is either a list of commands enclosed in brackets, or a +-- single command +parseClause :: ParseClauseType +parseClause [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseClause ts (is,ls2) fail succ +parseClause (OpenBracket:ts) inS fail succ + = parseArgs CloseBracket ts inS fail succ +parseClause ts inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + succ [a] ts2 inS2 + + +-- Parse Loop Statements -- + +-- parses loop statements +-- basically a dispatcher for other parse functions +makeLoop :: NameType -> ParseType +makeLoop "DO" = makeDo +makeLoop "WHILE" = makeWhile +makeLoop "REPEAT" = makeRepeat + +-- parses do statements +-- format: (DO WHILE ) +makeDo :: ParseType +makeDo ts inS fail succ + = parseClause ts inS fail $ \insts ts2 inS2 -> + parseWhileCond ts2 inS2 fail $ \cond ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Do cond insts) ts4 inS4 + +-- parses while conditions (both in while and do-while loops) +-- a condition is simply a command that (hopefully) returns a boolean +parseWhileCond :: ParseType +parseWhileCond [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseWhileCond ts (is,ls2) fail succ +parseWhileCond ((Normal "WHILE"):ts) inS fail succ + = parse ts inS fail succ + +-- parses while statements +-- format: (WHILE ) +makeWhile :: ParseType +makeWhile ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseClause ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop While cond insts) ts4 inS4 + +-- parses repeat statements +-- format: (REPEAT TIMES ) +-- note: is simply a command that (hopefully) returns an integer +makeRepeat :: ParseType +makeRepeat ts inS fail succ + = parse ts inS fail $ \num ts2 inS2 -> + parseRepeatBody ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Repeat num insts) ts4 inS4 + +-- parses repeat body (just a clause) +parseRepeatBody :: ParseClauseType +parseRepeatBody [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseRepeatBody ts (is,ls2) fail succ +parseRepeatBody ((Normal "TIMES"):ts) inS fail succ + = parseClause ts inS fail succ +parseRepeatBody _ inS fail _ + = fail "Repeat: invalid format" inS + + +-- Parse Graphics Statements -- + +-- parses all side-effecting graphics statements +makeGraphics :: CommandName -> ParseType +makeGraphics n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Graphics n as) ts2 inS2 + +-- Parse Trailing Parenthesis -- + +-- parses the closing paren terminating most commands +getParen :: [Token] -> InputState -> ParseFailType -> + ([Token] -> InputState -> IO ()) -> IO () +getParen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in getParen ts (is,ls) fail succ +getParen (CloseParen:ts) inS fail succ + = succ ts inS +getParen _ inS fail _ + = fail "Expected )" inS + diff --git a/progs/demo/X11/logo/logo.hu b/progs/demo/X11/logo/logo.hu new file mode 100644 index 0000000..388e926 --- /dev/null +++ b/progs/demo/X11/logo/logo.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +logo.hs -- cgit v1.2.3