diff --git a/samples/Clean/GenHylo.dcl b/samples/Clean/GenHylo.dcl new file mode 100644 index 00000000..eb95e68c --- /dev/null +++ b/samples/Clean/GenHylo.dcl @@ -0,0 +1,11 @@ +definition module GenHylo + +import StdGeneric, GenMap + +:: Fix f = In (f .(Fix f)) +Out :: !u:(Fix v:a) -> v:(a w:(Fix v:a)), [u <= w] + +hylo :: ((.f .b) -> .b) (.a -> (.f .a)) -> (.a -> .b) | gMap{|*->*|} f +cata :: (u:(f .a) -> .a) -> (Fix u:f) -> .a | gMap{|*->*|} f +ana :: (.a -> u:(f .a)) -> .a -> (Fix u:f) | gMap{|*->*|} f + diff --git a/samples/Clean/GenMap.dcl b/samples/Clean/GenMap.dcl new file mode 100644 index 00000000..bab284b8 --- /dev/null +++ b/samples/Clean/GenMap.dcl @@ -0,0 +1,9 @@ +definition module GenMap + +import StdGeneric + +generic gMap a b :: .a -> .b +derive gMap c, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, {}, {!} + +derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,) + diff --git a/samples/Clean/GenMap.icl b/samples/Clean/GenMap.icl new file mode 100644 index 00000000..1b06f9ae --- /dev/null +++ b/samples/Clean/GenMap.icl @@ -0,0 +1,19 @@ +implementation module GenMap + +import StdClass, StdArray, StdInt, StdFunc +import StdGeneric, _Array + +generic gMap a b :: .a -> .b +gMap{|c|} x = x +gMap{|UNIT|} x = x +gMap{|PAIR|} fx fy (PAIR x y) = PAIR (fx x) (fy y) +gMap{|EITHER|} fl fr (LEFT x) = LEFT (fl x) +gMap{|EITHER|} fl fr (RIGHT x) = RIGHT (fr x) +gMap{|CONS|} f (CONS x) = CONS (f x) +gMap{|FIELD|} f (FIELD x) = FIELD (f x) +gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x) +gMap{|{}|} f xs = mapArray f xs +gMap{|{!}|} f xs = mapArray f xs + +derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,) + diff --git a/samples/Clean/fsieve.icl b/samples/Clean/fsieve.icl new file mode 100644 index 00000000..fed72660 --- /dev/null +++ b/samples/Clean/fsieve.icl @@ -0,0 +1,54 @@ +module fsieve + +/* +The Fast Sieve of Eratosthenes. + +A sequential and optimized version of the sieve of Eratosthenes. +The program calculates a list of the first NrOfPrime primes. +The result of the program is the NrOfPrimes'th prime. + +Strictness annotations have been added because the strictness analyser +is not able to deduce all strictness information. Removal of these !'s +will make the program about 20% slower. + +On a machine without a math coprocessor the execution of this +program might take a (very) long time. Set NrOfPrimes to a smaller value. +*/ + +import StdClass; // RWS +import StdInt, StdReal + +NrOfPrimes :== 3000 + +// The sieve algorithm: generate an infinite list of all primes. + +Primes::[Int] +Primes = pr where pr = [5 : Sieve 7 4 pr] + +Sieve::Int !Int [Int] -> [Int] +Sieve g i prs + | IsPrime prs g (toInt (sqrt (toReal g))) = [g : Sieve` g i prs] + = Sieve (g + i) (6 - i) prs + +Sieve`::Int Int [Int] -> [Int] +Sieve` g i prs = Sieve (g + i) (6 - i) prs + +IsPrime::[Int] !Int Int -> Bool +IsPrime [f:r] pr bd | f>bd = True + | pr rem f==0 = False + = IsPrime r pr bd + +// Select is used to get the NrOfPrimes'th prime from the infinite list. + +Select::[x] Int -> x +Select [f:r] 1 = f +Select [f:r] n = Select r (n - 1) + + +/* The Start rule: Select the NrOfPrimes'th prime from the list of primes + generated by Primes. +*/ + +Start::Int +Start = Select [2, 3 : Primes] NrOfPrimes + diff --git a/samples/Clean/sem.icl b/samples/Clean/sem.icl new file mode 100644 index 00000000..8dce1cbe --- /dev/null +++ b/samples/Clean/sem.icl @@ -0,0 +1,99 @@ +module monadicSemantics + +import StdEnv, StdGeneric, GenMap, GenHylo + +/* For fun I implemented the recursive datastructre Exp and Stm as fixpoints + This helps us define recursive functions on them (only a little bit though) + However deriving gMap for Fix did not works out of the box + I had to remove some uniqueness typing in GenMap and GenHylo */ +:: Op = Plus | Minus | Times | Rem | Equal | LessThan +:: Var :== String + +:: ExpP a = Int Int | Var Var | Op Op a a +:: Exp :== Fix ExpP + +:: StmP a = Assign Var Exp | If Exp a a | While Exp a | Seq a a | Cont +:: Stm :== Fix StmP + +derive gMap ExpP, StmP, Fix + +// Environment. Semantics is basically Env -> Env +:: Env :== Var -> Int +:: Sem :== Env -> (Int, Env) +empty = \v . 0 + +// return +rtn :: Int -> Sem +rtn i = \e. (i, e) + +// the usual bind +(>>=) infixl 1 :: Sem (Int->Sem) -> Sem +(>>=) x y = \e. (\(i,e2).y i e2) (x e) +(>>|) infixl 1 :: Sem Sem -> Sem +(>>|) x y = x >>= \_. y + +// read variable from environment +read :: Var -> Sem +read v = \e. (e v, e) + +// assign value to give variable in environment +write :: Var Int -> Sem +write v i = \e. (i, \w. if (w==v) i (e w)) + +// semantics +class sem a :: a -> Sem + +operator :: Op -> Int -> Int -> Int +operator Plus = (+) +operator Minus = (-) +operator Times = (*) +operator Rem = rem +operator Equal = \x y . if (x==y) 1 0 +operator LessThan = \x y . if (x< y) 1 0 + +// semantics of expressions +instance sem Exp where + sem x = cata phi x where + phi (Int n) = rtn n + phi (Var v) = read v + phi (Op op x y) = x >>= \v1. y >>= return o (operator op v1) + +// semantics of statments +// NOTE: while will always return 0, as it might not even be executed +instance sem Stm where + sem x = cata phi x where + phi (Assign v e) = sem e >>= write v + phi (If e s1 s2) = sem e >>= \b . if (b<>0) s1 s2 + phi stm=:(While e s) = sem e >>= \b . if (b<>0) (s >>| phi stm) (phi Cont) + phi (Seq s1 s2) = s1 >>| s2 // Here the cata *finally* pays off :D + phi Cont = rtn 0 + +// convenience functions +int = In o Int +var = In o Var +op o = In o2 (Op o) +assign = In o2 Assign +ifte e = In o2 (If e) +while = In o2 While +seq = In o2 Seq +cont = In Cont + +// test case, also testing the new operator < +pEuclides = + while (op LessThan (int 0) (var "b"))( + seq (assign "r" (op Rem (var "a") (var "b"))) + (seq (assign "a" (var "b")) + ( (assign "b" (var "r"))) + ) + ) + +Start = fst (program start) where + program = sem pEuclides >>| read "a" + start "a" = 9 + start "b" = 12 + start _ = 0 + +// Helper +(o2) infixr 9 +(o2) f g x :== f o (g x) + diff --git a/samples/Clean/stack.dcl b/samples/Clean/stack.dcl new file mode 100644 index 00000000..21ca03c0 --- /dev/null +++ b/samples/Clean/stack.dcl @@ -0,0 +1,14 @@ +definition module stack + +:: Stack a + +newStack :: (Stack a) +push :: a (Stack a) -> Stack a +pushes :: [a] (Stack a) -> Stack a +pop :: (Stack a) -> Stack a +popn :: Int (Stack a) -> Stack a +top :: (Stack a) -> a +topn :: Int (Stack a) -> [a] +elements :: (Stack a) -> [a] +count :: (Stack a) -> Int + diff --git a/samples/Clean/stack.icl b/samples/Clean/stack.icl new file mode 100644 index 00000000..6175585a --- /dev/null +++ b/samples/Clean/stack.icl @@ -0,0 +1,33 @@ +implementation module stack +import StdEnv + +:: Stack a :== [a] + +newStack :: (Stack a) +newStack = [] + +push :: a (Stack a) -> Stack a +push x s = [x:s] + +pushes :: [a] (Stack a) -> Stack a +pushes x s = x ++ s + +pop :: (Stack a) -> Stack a +pop [] = abort "Cannot use pop on an empty stack" +pop [e:s] = s + +popn :: Int (Stack a) -> Stack a +popn n s = drop n s + +top :: (Stack a) -> a +top [] = abort "Cannot use top on an empty stack" +top [e:s] = e + +topn :: Int (Stack a) -> [a] +topn n s = take n s +elements :: (Stack a) -> [a] +elements s = s + +count :: (Stack a) -> Int +count s = length s + diff --git a/samples/Clean/streams.dcl b/samples/Clean/streams.dcl new file mode 100644 index 00000000..953a640a --- /dev/null +++ b/samples/Clean/streams.dcl @@ -0,0 +1,16 @@ +definition module streams + +import StdEnv + +instance zero [Real] +instance one [Real] +instance + [Real] +instance - [Real] +instance * [Real] +instance / [Real] + +X :: [Real] +invert :: [Real] -> [Real] +pow :: [Real] Int -> [Real] +(shuffle) infixl 7 :: [Real] [Real] -> [Real] + diff --git a/samples/Clean/streams.icl b/samples/Clean/streams.icl new file mode 100644 index 00000000..7f1fd849 --- /dev/null +++ b/samples/Clean/streams.icl @@ -0,0 +1,49 @@ +implementation module streams + +import StdEnv + +instance zero [Real] +where + zero = [] //Infinite row of zeroes represented as empty list to ease computation + +instance one [Real] +where + one = [1.0:zero] + +instance + [Real] +where + (+) [s:s`] [t:t`] = [s+t:s`+t`] + (+) [s:s`] [] = [s:s`] + (+) [] [t:t`] = [t:t`] + (+) [] [] = [] + +instance - [Real] +where + (-) [s:s`] [t:t`] = [s-t:s`-t`] + (-) [s:s`] [] = [s:s`] + (-) [] [t:t`] = [-1.0] * [t:t`] + (-) [] [] = [] + +instance * [Real] +where + (*) [s:s`] [t:t`] = [s*t:s`*[t:t`]+[s]*t`] + (*) _ _ = [] + +instance / [Real] +where + (/) s t = s * (invert t) + +X :: [Real] +X = [0.0:one] + +invert :: [Real] -> [Real] +invert [s:s`] = [1.0/s:(invert [s:s`]) * s` * [-1.0/s]] + +pow :: [Real] Int -> [Real] +pow s 0 = one +pow s n = s * pow s (n-1) + +(shuffle) infixl 7 :: [Real] [Real] -> [Real] +(shuffle) [s:s`] [t:t`] = [s*t:s` shuffle [t:t`] + [s:s`] shuffle t`] +(shuffle) _ _ = [] +