Bootstrap 4

2 files changed, 388 insertions, 0 deletions

diff --git a/assignment-4/serialize4.icl b/assignment-4/serialize4.icl
new file mode 100644
index 0000000..10026eb
--- /dev/null
+++ b/assignment-4/serialize4.icl
@@ -0,0 +1,232 @@
+module serialize4

+

+import StdEnv, StdMaybe, monad

+

+/*

+	Pieter Koopman, pieter@cs.ru.nl

+	Advanced Programming, week 4, 2017

+	

+	import StdMaybe from Libraries/StdLib

+	use StdEnv or StdEnv 64

+	use Basic Values Only as conclose option for a nicer output.

+*/

+

+// ---

+

+:: State s a = S (s -> (Maybe a,s))

+

+unS :: (State s a) -> s -> (Maybe a,s)

+unS (S f) = f

+

+instance Functor (State s) where

+	fmap f s = fail

+instance Applicative (State s) where

+	pure a = fail

+	(<*>) f x = fail

+instance fail (State s) where

+	fail = S \s.(Nothing,s)

+instance Monad (State s) where

+	bind a f = fail

+instance OrMonad (State s) where

+	(<|>) f g = fail

+

+// ---

+

+:: Serialized = Serialized

+

+ser :: Serialized

+ser = Serialized

+

+toStrings :: Serialized -> [String]

+toStrings _ = ["to be done\n"]

+

+:: Serialize a :== State Serialized a

+

+wrt :: a -> Serialize String | toString a

+wrt a = fail

+

+rd :: Serialize String

+rd = fail

+

+match :: a -> Serialize a | toString a

+match a = fail

+

+pred :: (String->Bool) -> Serialize String

+pred f = fail

+

+// ---

+

+:: UNIT     = UNIT

+:: EITHER a b = LEFT a | RIGHT b

+:: PAIR   a b = PAIR a b

+:: CONS   a   = CONS String a

+

+:: Write a :== a -> Serialize String

+:: Read a  :== Serialize a

+ 

+class serialize a | isUNIT a where

+  write :: a -> Serialize String

+  read  :: Serialize a

+

+class serialize1 t where

+  write1 :: (Write a) (t a) -> Serialize String

+  read1  :: (Read  a) -> Serialize (t a)

+

+class serializeCONS a where

+	writeCons :: (Write a) (CONS a) -> Serialize String

+	readCons  :: String (Read a) -> Serialize (CONS a)

+

+class serialize2 t where

+  write2 :: (Write a) (Write b) (t a b) -> Serialize String

+  read2  :: (Read  a) (Read  b) -> Serialize (t a b)

+

+class isUNIT a :: a -> Bool

+instance isUNIT UNIT where isUNIT _ = True

+instance isUNIT a    where isUNIT _ = False

+

+instance serialize Bool where

+  write b = fail

+  read = fail

+

+instance serialize Int where

+	write i = fail

+	read = fail

+

+instance serialize String where

+	write s = wrt s

+	read = fail

+

+instance serialize UNIT where

+	write _ = fail

+	read = fail

+

+instance serializeCONS UNIT where

+	writeCons wa (CONS name a) = fail

+	readCons name ra = fail

+ 

+instance serializeCONS a where

+	writeCons wa (CONS name a) = fail

+	readCons name ra =fail

+ 

+instance serialize2 EITHER where

+  write2 wa wb (LEFT  a) = fail

+  write2 wa wb (RIGHT b) = fail

+  read2 ra rb = fail

+

+instance serialize2 PAIR where

+  write2 wa wb (PAIR a b) = fail

+  read2 ra rb = fail

+

+// ---

+

+:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))

+

+fromList :: [a] -> ListG a

+fromList []  = LEFT  (CONS NilString  UNIT)

+fromList [a:x] = RIGHT (CONS ConsString (PAIR a x))

+

+toList :: (ListG a) -> [a]

+toList (LEFT  (CONS NilString  UNIT)) = []

+toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x]

+

+NilString :== "Nil"

+ConsString :== "Cons"

+

+instance serialize [a] | serialize a where

+ write a = write1 write a

+ read    = read1  read

+

+instance serialize1 [] where

+	write1 writea l = fail

+	read1  reada = fail

+// ---

+

+:: Bin a = Leaf | Bin (Bin a) a (Bin a)

+

+:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))

+

+fromBin :: (Bin a) -> BinG a

+fromBin Leaf = LEFT (CONS LeafString UNIT)

+fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r)))

+

+toBin :: (BinG a) -> Bin a

+toBin (LEFT (CONS _ UNIT)) = Leaf

+toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r

+

+LeafString :== "Leaf"

+BinString :== "Bin"

+

+instance == (Bin a) | == a where

+  (==) Leaf Leaf = True

+  (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s

+  (==) _ _ = False

+

+instance serialize (Bin a) | serialize a where

+	write b = fail

+	read = fail

+

+instance serialize1 Bin where

+	write1 writea b = fail

+	read1  reada    = fail

+// ---

+

+:: Coin = Head | Tail

+:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)

+

+fromCoin :: Coin -> CoinG

+fromCoin Head = LEFT (CONS "Head" UNIT)

+fromCoin Tail = RIGHT (CONS "Tail" UNIT)

+

+toCoin :: CoinG -> Coin

+toCoin (LEFT (CONS _ UNIT)) = Head

+toCoin (RIGHT (CONS _ UNIT)) = Tail

+

+instance == Coin where

+  (==) Head Head = True

+  (==) Tail Tail = True

+  (==) _    _    = False

+

+instance serialize Coin where

+	write c = fail

+	read    = fail

+

+// ---

+

+instance serialize (a,b) | serialize a & serialize b where

+	write (a,b) = fail

+	read = fail

+

+// ---

+

+Start = 

+  [test True

+  ,test False

+  ,test 0

+  ,test 123

+  ,test -36

+  ,test Head

+  ,test Tail

+  ,test [42]

+  ,test [0..4]

+  ,test [[True],[]]

+  ,test [[[1]],[[2],[3,4]],[[]]]

+  ,test [[True],[]]

+  ,test (Bin Leaf True Leaf)

+  ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))]

+  ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))]

+  ,test Head

+  ,test Tail

+  ,test (7,True)

+  ,test (Head,(7,[Tail]))

+  ,["End of the tests.\n"]

+  ]

+

+test :: a -> [String] | serialize, == a

+test a = toStrings (snd ((unS t) ser)) where

+ t

+ 	=   write a

+	>>| read

+	>>= \b. guard (a == b)

+	>>| write "Oke "

+	<|> write "Failure "

+

diff --git a/assignment-4/student.icl b/assignment-4/student.icl
new file mode 100644
index 0000000..fad269e
--- /dev/null
+++ b/assignment-4/student.icl
@@ -0,0 +1,156 @@
+module student

+

+import StdEnv, StdMaybe, monad

+/*

+	Pieter Koopman, pieter@cs.ru.nl

+	Advanced Programming, week 4

+*/

+

+// ---- an IO monad with maybe results --- //

+

+:: *State = {w :: *World, c :: *Maybe *File}

+:: IO a = IO (State -> *(Maybe a, State))

+

+open :: State -> State

+open {w, c=Nothing}

+	# (console, w) = stdio w

+	= {w = w, c = Just console}

+open s = s

+

+close :: State -> State

+close { w, c=Just f} = { w = snd (fclose f w), c = Nothing}

+close s = s

+

+unIO :: (IO a) -> State -> *(Maybe a, State)

+unIO (IO f) = f

+

+run :: (IO a) *World -> *World

+run m w = (close (snd (unIO m {w=w, c=Nothing}))).w

+

+// ---- reading from console --- //

+

+class read a :: IO a

+

+instance read String where

+	read = IO r where

+		r s 

+		#! {w,c=Just c} = open s

+		   (line, c) = freadline c

+		   s = rmNL line

+		| size s > 0

+			= (Just s,{w = w, c = Just c})

+			#! c = c <<< "String must be not empty "

+			   (line, c) = freadline c

+			   s = rmNL line

+			| size s > 0

+				= (Just s,  {w = w, c = Just c})

+				= (Nothing, {w = w, c = Just c})

+

+instance read Int where

+	read = IO r where

+		r s

+		#! {w,c=Just c} = open s

+		   (b,i,c) = freadi c

+		| b

+		= (Just i, {w = w, c = Just c})

+		#! (_, c) = freadline c

+		   c = c <<< "An integer please "

+		   (b,i,c) = freadi c

+		| b

+		= (Just i,  {w = w, c = Just c})

+		#! (_, c) = freadline c

+		= (Nothing, {w = w, c = Just c})

+

+write :: String -> IO String

+write mess = IO w where

+	w s

+	#! {w,c=Just c} = open s

+	= (Just mess,{w=w,c=Just (c <<< mess)})

+

+// ---- make IO a monad --- //

+

+instance Functor IO where

+	fmap f (IO g)

+		= IO \s.case g s of

+					(Just a, s) = (Just (f a),s)

+					(Nothing,s) = (Nothing  , s)

+

+instance Applicative IO where

+  pure a = IO \s.(Just a, s)

+  (<*>) (IO f) (IO g)

+   = IO \s.case f s of

+        (Just f,s) = case g s of

+  					(Just a,s) = (Just (f a),s)

+  					(n,     s) = (Nothing, s)

+        (n,     s) = (Nothing, s)

+

+instance Monad IO where

+	bind (IO f) g

+	 = IO \s.case f s of

+	 	(Just a, s) = unIO (g a) s

+	 	(n,      s) = (Nothing, s)

+

+instance fail IO where fail = IO \s.(Nothing,s)

+

+instance OrMonad IO where

+	<|> (IO f) (IO g) =

+		IO \s.case f s of

+			(Nothing, s) = g s

+			other        = other

+

+// ---- reading a student record --- //

+

+Start w = run f2 w

+

+:: Student =

+  { fname :: String

+  , lname :: String

+  , snum  :: Int

+  }

+

+instance toString Student where

+	toString {fname,lname,snum} = "{Student|fname=" + fname + ",lname=" + lname + ",snum=" + toString snum + "}"

+instance + String where + s t = s +++ t

+

+f0 :: *World -> (Student, *World)

+f0 world = ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world2) where

+	 (console1, world1) = stdio world

+	 console2 = console1 <<< "Your first name please: "

+	 (fname,console3) = freadline console2

+	 console4 = console3 <<< "Your last name please: "

+	 (lname,console5) = freadline console4

+	 console6 = console5 <<< "Your student nmber please: "

+	 (b1,snum,console7) = freadi console6

+	 (b2, world2) = fclose console7 world1

+

+f1 :: *World -> (Student, *World)

+f1 world

+  #! (console, world) = stdio world

+     console = console <<< "Your first name please: "

+     (fname,console) = freadline console

+     console = console <<< "Your last name please: "

+     (lname,console) = freadline console

+     console = console <<< "Your student nmber please: "

+     (b1,snum,console) = freadi console

+     (b2, world) = fclose console world

+  = ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world)

+

+f2 :: IO String

+f2 

+	= (        write "Your first name please: "

+	>>| read

+	>>= \fname.write "Your last name please: "

+	>>| read

+	>>= \lname.write "Your student nmber please: "

+	>>| read

+	>>= \snum. rtrn {fname = rmNL fname, lname = rmNL lname, snum = snum}

+	>>= write o toString)

+	<|> write "failed to read a student"

+

+rmNL :: String -> String

+rmNL string

+  # len = size string

+  | len > 0 && string.[len-1] == '\n'

+    = string % (0, len - 2)

+    = string

+