Some exercises

haskell/haskell4.hs

@@ -0,0 +1,65 @@
+lenght :: [a] -> Integer
+lenght [] = 0
+lenght (x:xs) = 1 + lenght xs
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)
+aTree = Branch (Leaf 'a') (Branch (Leaf 'b') (Leaf 'c'))
+
+ones = 1 : ones
+numsFrom n = n : numsFrom (n + 1)
+
+fib = 1 : 1 : [a + b | (a, b) <- zip fib (tail fib)]
+
+data TrafficLight = Red | Yellow | Green
+
+instance Eq TrafficLight where
+    Red == Red = True
+    Yellow == Yellow = True
+    Green == Green = True
+    _ == _ = False
+
+instance Show TrafficLight where
+    show Red = "The color of the semaphore is Red"
+    show Yellow = "The color of the semaphore is Yellow"
+    show Green = "The color of the semaphore is Green"
+
+data CMaybe a = CNothing | CJust Int a deriving (Show)
+
+instance Functor CMaybe where
+    fmap f CNothing = CNothing
+    fmap f (CJust counter x) = CJust (counter+1) (f x)
+
+applyMaybe :: Maybe a -> (a -> Maybe b) ->  Maybe b
+applyMaybe Nothing _ = Nothing
+applyMaybe (Just x) f = f x
+
+data Clist a = CNode a (Clist a) | CEnd (Clist a)
+instance (Eq a) => Eq (Clist a) where
+    CEnd _ == CEnd _ = True
+    (CNode a next) == (CNode b next2) = (a==b) && next == next2
+    _ == _ = False
+
+clist2list :: Clist a -> [a]
+clist2list (CEnd end) = []
+clist2list (CNode a next) = a : clist2list next
+
+list2clist :: [a] -> Clist a
+list2clist [] = let new = CEnd new
+                in new
+list2clist (x:xs) = let first = CNode x $ list2clist' xs first
+                    in first
+
+list2clist' [] first = CEnd first
+list2clist' (x:xs) first = CNode x $ list2clist' xs first
+
+cmap :: (a -> b) -> Clist a -> Clist b
+cmap f (CNode x next) = let first = CNode (f x) $ cmap' f next first
+                        in first
+cmap' f (CEnd x) first = (CEnd first)
+cmap' f (CNode x next) first = CNode (f x) $ cmap' f next first
+
+transpose :: [[a]] -> [[a]]
+transpose [] = []
+transpose ls = let hs = map head ls
+                   ts = filter (not . null) $ map tail ls
+               in hs : transpose ts

haskell/haskell5.hs

@@ -0,0 +1,135 @@
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+
+-- Logger
+type Log = [String]
+newtype Logger a = Logger {runLogger :: (a, Log)}
+
+--Let's define Log an instance of Show
+instance (Show a) => Show (Logger a ) where
+    show (Logger a) = show a
+
+--Define an instance of Functor for Logger
+loggerMap :: (a -> b) -> Logger a -> Logger b
+loggerMap f lg =
+    let (v, l) = runLogger lg
+        n = f v
+    in Logger (n, l)
+
+instance Functor Logger  where
+    fmap = loggerMap
+
+loggerApp :: Logger (a -> b) -> Logger a -> Logger b
+loggerApp lf lg =
+    let (f, s) = runLogger lf
+        nl = loggerMap f lg
+        (n, l) = runLogger nl
+    in Logger (n, l ++ s)
+
+instance Applicative Logger where
+    pure x = Logger (x, [])
+    (<*>) = loggerApp
+
+--Define the Logger Monad
+
+instance Monad Logger where
+    m >>= f = let (a, w) = runLogger m
+                  n = f a
+                  (b, x) = runLogger n
+              in Logger (b, w ++ x)
+
+--Define a function that takes a number, add one and log the operation
+logPlusOne :: (Num a) => a -> Logger a
+logPlusOne a = Logger (a+1, ["added one"])
+
+--Define a function that takes a number, doubles it and log the operation
+logMultiplyTwo :: (Num a) => a -> Logger a
+logMultiplyTwo a = Logger (a*2, ["Multiplied by two"])
+
+--Define a function that takes a logger, adds one, double the value and logs all the operations
+logOps :: (Num a) => a -> Logger a
+logOps a = pure a >>= logPlusOne >>= logMultiplyTwo
+
+logOps' :: (Num a) => Logger a -> Logger a
+logOps' a = do
+    v <- a
+    s1 <- logPlusOne v
+    p2 <- logMultiplyTwo s1
+    return p2
+
+--Define a record function to record things in the logPlusOne
+record :: String -> Logger ()
+record s = Logger ((), [s])
+
+--Define a binary Tree
+data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Eq, Read)
+
+treeFoldr :: (b -> a -> a) -> a -> Tree b -> a
+treeFoldr f acc EmptyTree = acc
+treeFoldr f acc (Node a left right) = treeFoldr f (f a (treeFoldr f acc right)) left
+
+singletonM :: (Show a) => a -> Logger (Tree a)
+singletonM x = do
+    record ("Created singleton" ++ show x)
+    return (Node x EmptyTree EmptyTree)
+
+treeInsertM :: (Ord a, Show a) => Tree a -> a -> Logger (Tree a)
+treeInsertM EmptyTree x = singletonM x
+treeInsertM (Node a left right) x
+    | x == a = do
+        record("Inserted " ++ show x)
+        return (Node x left right)
+    | x < a = do
+        l <- treeInsertM left x
+        return (Node a l right)
+    | x > a = do
+        r <- treeInsertM right x
+        return (Node a left r)
+treeSumM :: (Num a) => Logger (Tree a) -> Logger a
+treeSumM t = fmap (treeFoldr (+) 0) t
+
+andM :: Logger Bool -> Logger Bool -> Logger Bool
+andM log1 log2 = do
+    c1 <- log1
+    c2 <- log2
+    return (c1 && c2)
+
+treeBalancedM :: Tree a -> Logger Bool
+treeBalancedM EmptyTree = do
+    record "an empty tree is always balanced"
+    return True
+treeBalancedM (Node _ EmptyTree EmptyTree) = do
+    record "A single node tree is always balanced"
+    return True
+treeBalancedM (Node _ EmptyTree _) = do
+    record "Unbalanced"
+    return False
+treeBalancedM (Node _ _ EmptyTree) = do
+    record "Unbalanced"
+    return False
+treeBalancedM (Node _ left right) = andM (treeBalancedM left) (treeBalancedM right)
+
+type Stack = [Int]
+
+--Define the pop function
+pop :: Stack -> (Int, Stack)
+pop (x:xs) = (x, xs)
+
+--Define the push function
+push :: Int -> Stack -> ((), Stack)
+push x xs = ((), x:xs)
+
+stackManip :: Stack -> (Int, Stack)
+stackManip stack = let
+    (a, stack1) = pop stack
+    (b, stack2) = pop stack1
+    ((), stack3) = push 100 stack2
+    (c, stack4) = pop stack3
+    in pop stack4
+
+popM :: State Stack Int
+popM = do
+    x:xs <- get
+    put xs
+    return x

haskell/haskell6.hs

@@ -0,0 +1,48 @@
+
+
+data Bilist a = Bilist [a] [a] deriving (Show, Eq)
+
+bilist_ref (Bilist l r) pos = (l !! pos, r !! pos )
+
+--Define a function called oddeven, that is used to build a Bilist x y from a simple list2clist
+oddevenh :: [a] -> [a] -> [a] -> Bilist a
+oddevenh [] ev od = Bilist ev od
+oddevenh (x:xs) ev od = oddevenh xs od (ev ++ [x])
+
+oddeven :: [a] -> Bilist a
+oddeven list = oddevenh list [] []
+
+--Define an inverse function of oddeven
+inv_oddeven :: Bilist a -> [a]
+inv_oddeven (Bilist l r) = foldl (++) [] $ map (\(x,y) -> [x,y]) $ zip l r
+
+--Define a bilist_max function
+bilist_maxh (Bilist (l:ls) (r:rs)) pos curmax maxpos |
+    l+r > curmax = bilist_max (Bilist ls rs) (pos+1) (l+r) pos
+bilist_maxh (Bilist (l:ls) (r:rs)) pos curmax maxpos =
+    bilist_maxh (Bilist ls rs) (pos+1) curmax maxpos
+bilist_maxh _ _ _ maxpos = maxpos
+
+bilist_max (Bilist (l:ls) (r:rs)) = bilist_maxh (Bilist ls rs) 1 (l+r) 0
+
+data Lt a = Lt Int [[a]] deriving (Show, Eq)
+
+checkLt :: Lt a -> Bool
+checkLt (Lt _ []) = True
+checkLt (Lt k (x:xs)) = lenght x == k && checkLt (Lt k xs)
+
+sublists :: Int -> [a] -> [[a]] -> [[a]]
+sublists size lst res =
+    let factor = take size lst in
+    if lenght factor == size
+        then sublists size (tail lst) (factor:res)
+        else res
+
+checklist :: Eq a => [a] -> Lt a -> Maybe [[a]]
+checklist lst (Lt size ltf) =
+    let factors = sublists size lst []
+        nfactors = [x | x <- factors, not(x `elem` lft)]
+    in if nfactors == [] then Nothing else Just nfactors
+
+instance Functor Lt where
+    fmap f (Lt k lst) = Lt k $ map (\x -> map f x) lst

haskell/haskell7.hs

@@ -0,0 +1,49 @@
+import Control.Monad.State
+type Stack = [Int]
+
+
+--Define the pop function
+pop :: Stack -> (Int, Stack)
+pop (x:xs) = (x, xs)
+
+--Define the push function
+push :: Int -> Stack -> ((), Stack)
+push x xs = ((), x:xs)
+
+stackManip :: Stack -> (Int, Stack)
+stackManip stack = let
+    (a, stack1) = pop stack
+    (b, stack2) = pop stack1
+    ((), stack3) = push 100 stack2
+    (c, stack4) = pop stack3
+    in pop stack4
+
+popM :: State Stack Int
+popM = do
+    x:xs <- get
+    put xs
+    return x
+
+pushM :: Int -> State Stack ()
+pushM a = do
+    xs <- get
+    put (a:xs)
+    return()
+
+stackManipM :: State Stack Int
+stackManipM = do
+    popM
+    popM
+    pushM 100
+    popM
+    popM
+
+stackStuff :: State Stack ()
+stackStuff = do
+    a <- popM
+    if (a==5)
+        then return ()
+        else do
+            pushM 3
+            pushM 8
+            get

prolog/prolog3.pl

@@ -0,0 +1,28 @@
+determ(X,X) :- atomic(X), !.
+determ(T,Y) :- T =.. [X|Xs], (X = Y ; deterl(Xs, Y)).
+
+deterl([],_) :- !, fail.
+deterl([X|Xs],Y) :- determ(X,Y) ; deterl(Xs,Y).
+
+arrange(L1, L2, V, S1, S2) :- part(L1, V, S11,S12), part(L2, V, S21, S22), append(S11,S21,S1), append(S12,S22,S2).
+part([X|Xs], V, [X|L1], L2) :- X < V, part(Xs, V, L1, L2).
+part([X|Xs], V, L1, [X|L2]) :- X > V, part(Xs, V, L1, L2).
+part([V|Xs], V, L1, L2) :- !, part(Xs, V, L1, L2).
+part([], _, [], []).
+
+sumoftwo(L, V, X, Y) :- deepmember(X,L), deepmember(Y,L), V is X+Y.
+deepmember(X, [X|_]) :- atomic(X).
+deepmember(X, [Y|Ys]) :- deepmember(X,Y); deepmember(X,Ys).
+
+deeprev([],[]) :- !.
+deeprev([X|Xs], R) :- !, deeprev(X,V), deeprev(Xs,Vs), append(Vs, [V], R).
+deeprev(X,X) :- atomic(X).
+
+tripart([X|Xs],P1,P2,[X|L1],L2,L3) :- X < P1, X < P2, !, tripart(Xs, P1, P2, L1, L2, L3).
+tripart([X|Xs],P1,P2,L1,[X|L2],L3) :- X >= P1, X =< P2, !, tripart(Xs, P1, P2, L1, L2, L3).
+tripart([X|Xs],P1,P2,L1,L2,[X|L3]) :- X > P1, X > P2, !, tripart(Xs, P1, P2, L1, L2, L3).
+tripart([],_,_,[],[],[]).
+
+maxsum([X], [Y], R) :- !, R is X + Y.
+maxsum([X|Xs], [Y|Ys], T) :- maxsum(Xs,Ys,R), T is X + Y, T > R, !.
+maxsum([X|Xs], [Y|Ys], R) :- maxsum(Xs,Ys,R).

scheme/scheme5.rkt

@@ -0,0 +1,105 @@
+#lang racket
+(define saved-cont #f)
+
+(define (test-cont)
+  (let ((x 0))
+    (call/cc
+     (lambda (k)
+            (set! saved-cont k)))
+    (set! x (+ x 1))
+    (display x)
+    (newline)))
+
+(define (iterate f v)
+  (delay (cons v (iterate f (f v)))))
+
+(define (take n prom)
+  (if (= n 0)
+      '()
+      (let ((v (force prom)))
+        (cons (car v) (take (- n 1) (cdr v))))))
+
+(define (ftree treef treed)
+  (cond
+    ((null? treef) treed)
+    ((list? treef) (cons (ftree (car treef) (car treed))
+                         (ftree (cdr treef) (cdr treed))))
+    (else; should be atoms
+     (treef treed))))
+
+(define (first x y) x)
+
+(define (infinity) (+ 1 (infinity)))
+
+(define lazy-infinity (delay (infinity)))
+
+(define (re-map f L cond?)
+  (let loop ((res '())
+             (cur L))
+    (if (null? cur)
+        res
+        (let* ((k #f)
+               (v (call/cc
+                   (lambda (cont)
+                     (set! k cont)
+                     (f (car cur))))))
+          (if (cond? v)
+              (cons k v)
+              (loop (append res (list v))
+                    (cdr cur)))))))
+
+(struct cnode (value next) #:mutable)
+
+(define *end* '---end---)
+
+(define (cend)
+  (let ((node (cnode *end* #f)))
+    (set-cnode-next! node node)
+    node))
+(define (ccons x node)
+  (if (cend? node)
+      (let ((out (cnode x #f)))
+        (set-cnode-next! out node)
+        (set-cnode-next! node out)
+        out)
+      (let ((the-end (get-end node))
+            (out (cnode x node)))
+        (set-cnode-next! the-end out)
+        out)))
+
+(define (cend? clist)
+  (and (cnode? clist)
+       (eq? (cnode-value clist) *end*)))
+
+(define (get-end clist)
+  (if (cend? clist)
+      clist
+      (get-end (cnode-next clist))))
+
+(define (cmap f clist)
+  (if (cend? clist)
+      (cend)
+      (ccons (f (cnode-value clist))
+             (cmap f (cnode-next clist)))))
+
+(define-syntax-rule (my-while condition body ...)
+  (let loop ()
+    (when condition
+      body ...
+      (loop))))
+
+(define (genFig n)
+  (let loop ((f '())
+             (k 0))
+    (if (< k n)
+           (loop (cons (genRow n k) f)
+                 (+ k 1))
+    f)))
+
+(define (genRow n k)
+  (let loop ((r '())
+             (i 0))
+    (if (< i n)
+           (loop (cons (if (= i k) 1 0) r)
+                 (+ i 1))
+    r)))

scheme/scheme6.rkt

@@ -0,0 +1,72 @@
+#lang racket
+(define (sublists lst k)
+  (let ((curr lst)
+        (size (length lst)))
+    (lambda ()
+      (if (< size k)
+          'end
+          (begin
+            (let ((v (take curr k)))
+              (set! size (- size 1))
+              (set! curr (cdr curr))
+              v))))))
+
+(define (checklist lst factors)
+  (let* ((k (length (car factors)))
+         (iter (sublists lst k)))
+    (foldl
+     (lambda (x r)
+       (let ((curr (iter)))
+         (if (member curr (cons 'end factors))
+             r
+             (cons curr r))))
+     '()
+     lst)))
+
+(checklist '(b b a a b b b c) '((a b) (b a) (b b)))
+
+(define (test lst)
+  (foldl
+   (λ (r x)
+     (cons x r))
+   1
+   lst))
+
+(test '(2 3))
+
+
+(define (co-sublist lst i j)
+  (let loop ((p 0)
+             (res '())
+             (rem-lst lst))
+    (cond
+      ((null? rem-lst)
+       res)
+      ((or (< p i) (> p j))
+       (loop (+ p 1)
+             (append res (list (car rem-lst)))
+             (cdr rem-lst)))
+      (else  
+       (loop (+ p 1)
+             res
+             (cdr rem-lst))))))
+
+(define -> '->)
+(define <- '<-)
+
+(define (subl . args)
+  (let loop ((state #f)
+             (res '())
+             (rem-lst args))
+    (cond
+      ((null? rem-lst)
+       res)
+      ((eq? (car rem-lst) '<-)
+       (loop #f res (cdr rem-lst)))
+      ((eq? (car rem-lst) '->)
+       (loop #t res (cdr rem-lst)))
+      (state
+       (loop state (append res (list (car rem-lst))) (cdr rem-lst)))
+      ((not state)
+       (loop state res (cdr rem-lst))))))
+

scheme/scheme7.rkt

@@ -0,0 +1,152 @@
+#lang racket
+(struct being (
+               name
+               (age #:mutable)
+               ))
+
+(define (being-show x)
+  (display (being-name x))
+  (display " (")
+  (display (being-age x))
+  (display ")"))
+
+(define (say-hello x)
+  (if (being? x)
+      (begin
+        (being-show x)
+        (display ": my regards.")
+        (newline))
+      (error "not a being")))
+
+(define andrea (being "andrea" 23))
+
+(say-hello andrea)
+(set-being-age! andrea 24)
+(say-hello andrea)
+
+(struct may-being being
+  ((alive? #:mutable))
+  )
+
+(define (kill! x)
+  (if (may-being? x)
+      (set-may-being-alive?! x #f)
+      (error "not a may-being")))
+
+(define andrea-son (may-being "andrea-son" 23 #t))
+(say-hello andrea-son)
+(may-being? andrea)
+(may-being? andrea-son)
+(being? andrea-son)
+(kill! andrea-son)
+(say-hello andrea-son)
+
+(define (try-to-say-hello x)
+  (if (and
+       (may-being? x)
+       (not (may-being-alive? x)))
+      (begin
+        (display "I hear only silence")
+        (newline))
+      (say-hello x)))
+(try-to-say-hello andrea)
+(try-to-say-hello andrea-son)
+
+(define (make-simple-object)
+  (let ((my-var 0))
+    (define (init)
+      (set! my-var 0)
+      my-var)
+    (define (my-add x)
+      (set! my-var (+ my-var x))
+      my-var)
+    (define (get-my-var)
+      my-var)
+    (define (my-display)
+      (newline)
+      (display "my Var is:")
+      (display my-var)
+      (newline))
+
+    (lambda (message . args)
+      (apply (case message
+               ((init) init)
+               ((my-add) my-add)
+               ((my-display) my-display)
+               ((get-my-var) get-my-var)
+               (else (error "Unknown method!")))
+             args))))
+
+(define obj1 (make-simple-object))
+(obj1 'init)
+(obj1 'my-add 3)
+
+(define (make-son)
+  (let ((parent (make-simple-object))
+        (name "an object"))
+    (define (init)
+      (parent 'init))
+    (define (hello)
+      "hi!")
+    (define (my-display)
+      (display "My name is ")
+      (display name)
+      (display " and")
+      (parent 'my-display))
+    (lambda (message . args)
+      (case message
+        ((init) (apply init args))
+        ((my-display) (apply my-display args))
+        ((hello) (apply hello args))
+        (else (apply parent (cons message args)))))))
+
+(define obj2 (make-son))
+(obj2 'init)
+(obj2 'my-display)
+(obj2 'hello)
+
+(define new-object make-hash)
+
+(define (clone object)
+  (hash-copy object))
+
+(define-syntax !!
+  (syntax-rules ()
+    ((_ object msg new-val)
+     (hash-set! object 'msg new-val))))
+
+(define-syntax ??
+  (syntax-rules ()
+    ((_ object msg)
+     (hash-ref object 'msg))))
+
+(define-syntax ->
+  (syntax-rules ()
+    ((_ object msg arg ...)
+     ((hash-ref object 'msg) object arg ...))))
+
+(define Pino (new-object))
+(!! Pino name "Pino")
+(!! Pino hello
+    (lambda (self x)
+      (display (?? self name))
+      (display ": hi, ")
+      (display (?? x name))
+      (display "!")
+      (newline)))
+
+(!! Pino set-name
+    (lambda (self x)
+      (!! self name x)))
+(!! Pino set-name-&-age
+    (λ (self n a)
+      (!! self name n)
+      (!! self age a)))
+
+(define Pina (clone Pino))
+(!! Pina name "Pina")
+
+(-> Pino hello Pina)
+(-> Pino set-name "Ugo")
+(-> Pina set-name-&-age "Lucia" 25)
+(-> Pino hello Pina)

scheme/scheme8.rkt

@@ -0,0 +1,66 @@
+#lang racket
+(define new-object make-hash)
+
+(define (clone object)
+  (hash-copy object))
+
+(define-syntax !!
+  (syntax-rules()
+    ((_ object msg new-val)
+     (hash-set! object 'msg new-val))))
+(define-syntax ??
+  (syntax-rules ()
+    ((_ object msg)
+     (dispatch object 'msg))))
+
+(define-syntax ->
+  (syntax-rules ()
+    ((_ object msg arg ...)
+     ((dispatch object 'msg) object arg ...))))
+
+(define (son-of parent)
+  (let ((o (new-object)))
+    (!! o <<parent>> parent)
+    o))
+
+(define (dispatch object msg)
+  (if (eq? object 'unknown)
+      (error "Unknown message" msg)
+      (let ((slot (hash-ref object msg 'unknown)))
+        (if (eq? slot 'unknown)
+            (dispatch (hash-ref object '<<parent>> 'unknown) msg)
+            slot))))
+
+(define Pino (new-object))
+(!! Pino name "Pino")
+(!! Pino hello
+    (lambda (self x)
+      (display (?? self name))
+      (display ": hi, ")
+      (display (?? x name))
+      (display "!")
+      (newline)))
+
+(!! Pino set-name
+    (lambda (self x)
+      (!! self name x)))
+(!! Pino set-name-&-age
+    (λ (self n a)
+      (!! self name n)
+      (!! self age a)))
+
+(define Pina (clone Pino))
+(!! Pina name "Pina")
+
+(-> Pino hello Pina)
+(-> Pino set-name "Ugo")
+(-> Pina set-name-&-age "Lucia" 25)
+(-> Pino hello Pina)
+
+(define Glenn (son-of Pino))
+(?? Glenn name)
+(!! Glenn name "Glenn")
+(!! Glenn age 50)
+
+(-> Glenn hello Pina)
+