assignment 12 WIP

[ap2015.git] / a12 / charlie / skeleton12.icl

diff --git a/a12/charlie/skeleton12.icl b/a12/charlie/skeleton12.icl
new file mode 100644 (file)
index 0000000..6d300c3
--- /dev/null
+++ b/a12/charlie/skeleton12.icl
@@ -0,0 +1,105 @@
+module skeleton12
+
+import Data.Maybe
+import Control.Monad
+import StdInt, StdString, StdBool
+
+class arith x where
+       lit :: a -> x a | toString a
+       (+.) infixl 6 :: (x a) (x a) -> x a | + a // integer addition, Boolean OR
+       (*.) infixl 7 :: (x a) (x a) -> x a | * a // integer multiplication, Boolean AND
+class store x where
+       read  :: (x Int)
+       write :: (x Int) -> x Int
+class truth x where
+       (XOR) infixr 3 :: (x Bool) (x Bool) -> x Bool
+       -.    :: (x Bool) -> x Bool
+class (=.=) infix 4 x :: (x a) (x a) -> x Bool | == a
+class except x where
+       throw :: (x a)
+       try   :: (x a) (x a) -> x a
+
+class aexpr x | arith, store, except, =.= x
+class bexpr x | arith, truth, except, =.= x
+class expr x  | aexpr, bexpr x
+
+:: Step a = Step (State -> (Maybe a, State))
+:: State :== Int
+
+instance Functor Step where
+       fmap f (Step g) = Step \st . h (g st) where
+               h (Just x, st) = (Just (f x), st)
+               h (Nothing, st) = (Nothing, st)
+
+instance Applicative Step where
+       pure x = Step \st . (Just x, st)
+       (<*>) (Step f) (Step g) = Step \st . h (f st) where
+               h (Just f, st) = q f (g st)
+               h (Nothing, st) = (Nothing, st)
+               q f (Just x, st) = (Just (f x), st)
+               q _ (Nothing, st) = (Nothing, st)
+
+instance Monad Step where
+       bind (Step f) g = Step \st . h (f st) where
+               h (Just x, st) = q (g x) st
+               h (Nothing, st) = (Nothing, st)
+               q (Step f) st = f st
+
+instance arith Step where
+       lit x = return x
+       (+.) x y = x >>= \x` . y >>= \y` . return (x`+y`)
+       (*.) x y = x >>= \x` . y >>= \y` . return (x`*y`)
+
+instance store Step where
+       read = Step \st . (Just st, st)
+       write x = x >>= \x` . Step \st . (Just x`, x`)
+
+instance truth Step where
+       (XOR) x y = x >>= \x` . y >>= \y` . return (x` bitxor y`)
+       -. x = x >>= \x` . return (not x`)
+
+seven :: e Int | aexpr e
+seven = lit 3 +. lit 4
+
+throw1 :: e Int | expr e
+throw1 = lit 3 +. throw
+
+six :: e Int | expr e
+six = write (lit 3) +. read
+
+try1 :: e Int | expr e
+try1 = try throw1 (lit 42)
+
+/*loge :: e Bool | expr e
+loge = lit True *. -. (lit True)*/
+
+comp :: e Bool | expr e
+comp = lit 1 =.= lit 2 XOR -. (-. (lit True))
+
+:: Show a = Show ([String] -> [String])
+
+instance arith Show where
+       lit x = Show \xs . [toString x:xs]
+       (+.) (Show f) (Show g) = Show \xs . f ["+":g xs]
+       (*.) (Show f) (Show g) = Show \xs . f ["*":g xs]
+
+instance store Show where
+       read = Show \xs . ["read":xs]
+       write (Show f) = Show \xs . ["write":f xs]
+       
+instance truth Show where
+       (XOR) (Show f) (Show g) = Show \xs . f ["XOR":g xs]
+       -. (Show f) = Show \xs . ["!":f xs]
+
+instance =.= Show where
+       (=.=)(Show f) (Show g) = Show \xs . f ["==":g xs]
+
+instance except Show where
+       throw = Show \xs . ["throw":xs]
+       try (Show f) (Show g) = Show \xs . ["try":f ["catch":g xs]]
+
+show :: (Show a) -> [String]
+show (Show f) = f []
+
+Start :: Step Bool
+Start = comp >>= return