Initial code structure

cp2223t/BTree.hs

@@ -0,0 +1,205 @@
+{-# OPTIONS_GHC -XNPlusKPatterns #-}
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module BTree where
+
+import Cp
+import Data.List
+import Data.Monoid
+
+-- (1) Datatype definition -----------------------------------------------------
+
+data BTree a = Empty | Node(a, (BTree a, BTree a)) deriving Show
+
+inBTree :: Either () (b,(BTree b,BTree b)) -> BTree b
+inBTree = either (const Empty) Node
+
+outBTree :: BTree a -> Either () (a,(BTree a,BTree a))
+outBTree Empty              = Left ()
+outBTree (Node (a,(t1,t2))) = Right(a,(t1,t2))
+
+baseBTree g f = id -|- g >< (f >< f)
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recBTree f = id -|- id >< (f >< f) -- = baseBTree id f
+
+cataBTree g = g . (recBTree (cataBTree g)) . outBTree
+
+anaBTree g = inBTree . (recBTree (anaBTree g) ) . g
+
+hyloBTree f g = cataBTree f . anaBTree g
+
+-- (3) Map ---------------------------------------------------------------------
+
+instance Functor BTree
+         where fmap f = cataBTree ( inBTree . baseBTree f id )
+
+-- equivalent to:
+--       where fmap f = anaBTree ( baseBTree f id . outBTree )
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- (4.1) Inversion (mirror) ----------------------------------------------------
+
+mirrorBTree = cataBTree (inBTree . (id -|- id >< swap))
+
+-- (4.2) Count and depth -------------------------------------------------------
+
+countBTree = cataBTree (either (const 0) (succ . (uncurry (+)) . p2))
+
+depthBTree = cataBTree (either zero (succ.umax.p2))
+
+-- (4.3) Serialization ---------------------------------------------------------
+
+inordt = cataBTree inord     -- in-order traversal
+
+preordt = cataBTree preord  -- pre-order traversal
+
+postordt = cataBTree posord -- post-order traversal
+
+-- where
+
+preord = either nil f where f(x,(l,r))=x:l++r
+inord  = either nil f where f(x,(l,r))=l++[x]++r
+posord = either nil f where f(x,(l,r))=l++r++[x]
+
+-- (4.4) Quicksort -------------------------------------------------------------
+
+qSort :: Ord a => [a] -> [a]
+qSort = hyloBTree inord qsep -- the same as (cataBTree inord) . (anaBTree qsep)
+
+-- where
+
+qsep []    = i1 ()
+qsep (h:t) = i2 (h,(s,l)) where (s,l) = part (<h) t
+
+part:: (a -> Bool) -> [a] -> ([a], [a])
+part p []                = ([],[])
+part p (h:t) | p h       = let (s,l) = part p t in (h:s,l)
+     | otherwise = let (s,l) = part p t in (s,h:l)
+
+{-- pointwise versions:
+qSort [] = []
+qSort (h:t) = let (t1,t2) = part (<h) t
+      in  qSort t1 ++ [h] ++ qSort t2
+
+or, using list comprehensions:
+
+qSort [] = []
+qSort (h:t) = qSort [ a | a <- t , a < h ] ++ [h] ++ 
+      qSort [ a | a <- t , a >= h ]
+
+--}
+
+-- (4.5) Traces ----------------------------------------------------------------
+
+traces :: Eq a => BTree a -> [[a]]
+traces = cataBTree (either (const [[]]) tunion)
+   where tunion(a,(l,r)) = union (map (a:) l) (map (a:) r) 
+
+-- (4.6) Towers of Hanoi -------------------------------------------------------
+
+-- pointwise:
+-- hanoi(d,0) = []
+-- hanoi(d,n+1) = (hanoi (not d,n)) ++ [(n,d)] ++ (hanoi (not d, n))
+
+hanoi = hyloBTree present strategy
+
+--- where
+
+present = inord -- same as in qSort
+
+strategy(d,0) = Left ()
+strategy(d,n+1) = Right ((n,d),((not d,n),(not d,n)))
+
+{--
+    The Towers of Hanoi problem comes from a puzzle marketed in 1883
+    by the French mathematician Édouard Lucas, under the pseudonym
+    Claus. The puzzle is based on a legend according to which
+    there is a temple, apparently in Bramah rather than in Hanoi as
+    one might expect, where there are three giant poles fixed in the
+    ground. On the first of these poles, at the time of the world's
+    creation, God placed sixty four golden disks, each of different
+    size, in decreasing order of size. The Bramin monks were given
+    the task of moving the disks, one per day, from one pole to another
+    subject to the rule that no disk may ever be above a smaller disk.
+    The monks' task would be complete when they had succeeded in moving
+    all the disks from the first of the poles to the second and, on
+    the day that they completed their task the world would come to
+    an end!
+    
+    There is a well­known inductive solution to the problem given
+    by the pseudocode below. In this solution we make use of the fact
+    that the given problem is symmetrical with respect to all three
+    poles. Thus it is undesirable to name the individual poles. Instead
+    we visualize the poles as being arranged in a circle; the problem
+    is to move the tower of disks from one pole to the next pole in
+    a specified direction around the circle. The code defines H n d
+    to be a sequence of pairs (k,d') where n is the number of disks,
+    k is a disk number and d and d' are directions. Disks are numbered
+    from 0 onwards, disk 0 being the smallest. (Assigning number 0
+    to the smallest rather than the largest disk has the advantage
+    that the number of the disk that is moved on any day is independent
+    of the total number of disks to be moved.) Directions are boolean
+    values, true representing a clockwise movement and false an anti­clockwise
+    movement. The pair (k,d') means move the disk numbered k from
+    its current position in the direction d'. The semicolon operator
+    concatenates sequences together, [] denotes an empty sequence
+    and [x] is a sequence with exactly one element x. Taking the pairs
+    in order from left to right, the complete sequence H n d prescribes
+    how to move the n smallest disks one­by­one from one pole to the
+    next pole in the direction d following the rule of never placing
+    a larger disk on top of a smaller disk.
+    
+    H 0     d = [],
+    H (n+1) d = H n ¬d ; [ (n, d) ] ; H n ¬d.
+    
+    (excerpt from R. Backhouse, M. Fokkinga / Information Processing
+    Letters 77 (2001) 71--76)
+    
+--}
+
+-- (5) Depth and balancing (using mutual recursion) --------------------------
+
+balBTree = p1.baldepth
+
+baldepthBTree = p2.baldepth
+
+baldepth = cataBTree g where
+     g = either (const(True,1)) (h.(id><f))
+     h(a,((b1,b2),(d1,d2))) = (b1 && b2 && abs(d1-d2)<=1,1+max d1 d2)
+     f((b1,d1),(b2,d2)) = ((b1,b2),(d1,d2))
+
+-- (6) Going polytipic -------------------------------------------------------
+
+-- natural transformation from base functor to monoid
+tnat :: Monoid c => (a -> c) -> Either () (a,(c, c)) -> c
+tnat f = either (const mempty) (theta . (f >< theta))
+         where theta = uncurry mappend
+
+-- monoid reduction
+
+monBTree f = cataBTree (tnat f)
+
+-- alternative to (4.2) serialization ----------------------------------------
+
+preordt' = monBTree singl
+
+-- alternative to (4.1) counting ---------------------------------------------
+
+countBTree' = monBTree (const (Sum 1))
+
+-- (7) Zipper ----------------------------------------------------------------
+
+data Deriv a = Dr Bool a (BTree a)
+
+type Zipper a = [ Deriv a ]
+
+plug :: Zipper a -> BTree a -> BTree a
+plug [] t = t
+plug ((Dr False a l):z) t = Node (a,(plug z t,l))
+plug ((Dr True  a r):z) t = Node (a,(r,plug z t))
+
+---------------------------- end of library ----------------------------------

cp2223t/Cp.hs

@@ -0,0 +1,260 @@
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module Cp where
+
+infix 5  ><
+infix 4  -|-
+
+-- (1) Product -----------------------------------------------------------------
+
+split :: (a -> b) -> (a -> c) -> a -> (b,c)
+split f g x = (f x, g x)
+
+(><) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)
+f >< g = split (f . p1) (g . p2)
+
+-- the 0-adic split 
+
+(!) :: a -> ()
+(!) = const ()
+
+-- Renamings:
+
+p1        = fst
+p2        = snd
+
+-- diagonal (dup)
+
+diag = split id id
+
+-- (2) Coproduct ---------------------------------------------------------------
+
+-- Renamings:
+
+i1      = Left
+i2      = Right
+
+-- either is predefined
+
+(-|-) :: (a -> b) -> (c -> d) -> Either a c -> Either b d
+f -|- g = either (i1 . f) (i2 . g)
+
+-- McCarthy's conditional:
+
+cond p f g = (either f g) . (grd p)
+
+-- codiagonal (join)
+
+codiag = either id id
+
+-- (3) Exponentiation ---------------------------------------------------------
+
+-- curry is predefined
+
+ap :: (a -> b,a) -> b
+ap = uncurry ($)
+
+expn :: (b -> c) -> (a -> b) -> a -> c
+expn f = curry (f . ap)
+
+p2p :: (a, a) -> Bool -> a
+p2p p b = if b then (snd p) else (fst p) -- pair to predicate
+
+-- exponentiation functor is (a->) predefined 
+
+-- instance Functor ((->) s) where fmap f g = f . g
+
+-- (4) Others -----------------------------------------------------------------
+
+--const :: a -> b -> a st const a x = a is predefined
+
+-- guards
+
+grd :: (a -> Bool) -> a -> Either a a
+grd p x = if p x then i1 x else i2 x
+
+-- (5) Natural isomorphisms ----------------------------------------------------
+
+swap :: (a,b) -> (b,a)
+swap = split p2 p1
+
+assocr :: ((a,b),c) -> (a,(b,c))
+assocr = split ( p1 . p1 ) (p2 >< id)
+
+assocl :: (a,(b,c)) -> ((a,b),c)
+assocl = split ( id >< p1 ) ( p2 . p2 )
+
+undistr :: Either (a,b) (a,c) -> (a,Either b c)
+undistr = either ( id >< i1 ) ( id >< i2 )
+
+undistl :: Either (b, c) (a, c) -> (Either b a, c)
+undistl = either ( i1 >< id ) ( i2 >< id )
+
+flatr :: (a,(b,c)) -> (a,b,c)
+flatr (a,(b,c)) = (a,b,c)
+
+flatl :: ((a,b),c) -> (a,b,c)
+flatl ((b,c),d) = (b,c,d)
+
+br :: a -> (a, ())
+br = split id (!) -- 'bang' on the right
+
+bl :: a -> ((), a)
+bl = swap . br -- 'bang' on the left
+
+coswap :: Either a b -> Either b a
+coswap = either i2 i1
+
+coassocr :: Either (Either a b) c -> Either a (Either b c)
+coassocr = either (id -|- i1) (i2 . i2)
+
+coassocl :: Either b (Either a c) -> Either (Either b a) c
+coassocl = either (i1.i1) (i2 -|- id)
+
+distl :: (Either c a, b) -> Either (c, b) (a, b)
+distl = uncurry (either (curry i1)(curry i2))
+
+distr :: (b, Either c a) -> Either (b, c) (b, a)
+distr = (swap -|- swap) . distl . swap
+
+colambda :: (a, a) -> Bool -> a
+colambda (a,b) = f where f True = a; f False = b
+
+lambda :: (Bool -> a) -> (a, a)
+lambda f = (f False, f True)
+
+-- (6) Class bifunctor ---------------------------------------------------------
+
+class BiFunctor f where
+      bmap :: (a -> b) -> (c -> d) -> (f a c -> f b d)
+
+instance BiFunctor Either where
+    bmap f g = f -|- g
+
+instance BiFunctor (,) where
+    bmap f g  = f >< g
+
+-- (7) Monads: -----------------------------------------------------------------
+
+-- (7.1) Kleisli monadic composition -------------------------------------------
+
+infix 4  .!
+
+(.!) :: Monad a => (b -> a c) -> (d -> a b) -> d -> a c
+(f .! g) a = (g a) >>= f
+
+mult :: (Monad m) => m (m b) -> m b
+mult = (>>= id)  -- also known as join
+
+-- (7.2) Monadic binding ---------------------------------------------------------
+
+ap' :: (Monad m) => (a -> m b, m a) -> m b
+ap' = uncurry (flip (>>=))
+
+-- (7.3) Lists
+
+singl :: a -> [a]
+singl = return
+
+-- (7.4) Strong monads -----------------------------------------------------------
+
+class (Functor f, Monad f) => Strong f where
+      rstr :: (f a,b) -> f(a,b)
+      rstr(x,b) = do a <- x ; return (a,b)
+      lstr :: (b,f a) -> f(b,a)
+      lstr(b,x) = do a <- x ; return (b,a)
+
+instance Strong IO
+
+instance Strong []
+
+instance Strong Maybe
+
+dstr :: Strong m => (m a, m b) -> m (a, b)       --- double strength
+dstr = rstr .! lstr
+
+splitm :: Strong ff => ff (a -> b) -> a -> ff b
+-- Exercise 4.8.13 in Jacobs' "Introduction to Coalgebra" (2012)
+splitm = curry (fmap ap . rstr)
+
+{--
+-- (7.5) Monad transformers ------------------------------------------------------
+
+class (Monad m, Monad (t m))  => MT t m where   -- monad transformer class
+      lift :: m a -> t m a
+
+-- nested lifting:
+
+dlift :: (MT t (t1 m), MT t1 m) => m a -> t (t1 m) a
+dlift = lift . lift
+
+--}
+
+-- (8) Basic functions, abbreviations ------------------------------------------
+
+bang = (!)
+
+dup = split id id
+
+zero = const 0
+
+one  = const 1
+
+nil = const []
+
+cons = uncurry (:)
+
+add = uncurry (+)
+
+mul = uncurry (*)
+
+conc = uncurry (++)
+
+umax :: Ord a => (a,a) -> a
+umax = uncurry max
+
+true = const True
+
+nothing = const Nothing
+
+false = const False
+
+inMaybe :: Either () a -> Maybe a
+inMaybe = either (const Nothing) Just
+
+nat0 = [0..] -- the natural numbers
+
+-- (9) Advanced ----------------------------------------------------------------
+
+class (Functor f) => Unzipable f where
+      unzp :: f(a,b) -> (f a,f b)
+      unzp = split (fmap p1)(fmap p2)
+
+class Functor g => DistL g where
+      lamb :: Monad m => g (m a) -> m (g a)
+
+instance DistL [] where lamb = sequence
+
+instance DistL Maybe where
+      lamb Nothing  = return Nothing
+      lamb (Just a) = fmap Just a  -- where mp f = (return.f).!id
+
+aap :: Monad m  => m (a->b) -> m a -> m b
+-- to convert Monad into Applicative
+-- (<*>) = curry(lift ap) where lift h (x,y) = do { a <- x; b <- y; return ((curry h a b)) }
+aap mf mx = do { f <- mf ; x <- mx ; return (f x) }
+
+-- gather: n-ary split
+
+gather :: [a -> b] -> a -> [b]
+gather l x = map (flip ($) x) l
+
+-- the dual of zip
+
+cozip :: (Functor f) => Either (f a) (f b) -> f (Either a b)
+cozip = either (fmap Left)(fmap Right)
+
+tot :: (a -> b) -> (a -> Bool) -> a -> Maybe b
+tot f p = cond p (return . f) nothing
+--------------------------------------------------------------------------------

cp2223t/Exp.hs

@@ -0,0 +1,221 @@
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module Exp where
+
+import Cp
+import BTree
+import LTree
+import FTree
+import System.Process
+import GHC.IO.Exception
+import St
+import List hiding (lookup)
+import Data.List
+import RelCalc
+
+-- (0) Functions dependent on your OS -------------------------------------
+
+wopen = ("start/b "++)
+mopen = ("open    "++)
+
+--1) Windows
+
+--open = wopen
+
+--2) Mac OS
+
+open = mopen 
+
+expShow fn e = do { expDisplay fn (mirrorExp e) ; system(open fn) }
+
+-- (1) Datatype definition -----------------------------------------------------
+
+data Exp v o =   Var v              -- expressions are either variables
+               | Term o [ Exp v o ] -- or terms involving operators and
+                                    -- subterms
+               deriving (Show,Eq)
+
+inExp = either Var (uncurry Term)
+outExp(Var v) = i1 v
+outExp(Term o l) = i2(o,l)
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+baseExp f g h = f -|- (g >< map h)
+
+recExp x = baseExp id id x
+
+cataExp g = g . recExp (cataExp g) . outExp
+
+anaExp g = inExp . recExp (anaExp g) . g
+
+hyloExp h g = cataExp h . anaExp g
+
+-- (3) Map ---------------------------------------------------------------------
+
+instance BiFunctor Exp
+         where bmap f g = cataExp ( inExp . baseExp f g id )
+
+-- (4) Examples ----------------------------------------------------------------
+
+mirrorExp = cataExp (inExp . (id -|- (id><reverse)))
+
+expLeaves :: Exp a b -> [a]
+expLeaves = cataExp (either singl (concat . p2))
+
+expOps :: Exp a b -> [b]
+expOps = cataExp (either nil (cons . (id><concat)))
+
+expWidth :: Exp a b -> Int
+expWidth = length . expLeaves
+
+expDepth :: Exp a b -> Int
+expDepth = cataExp (either (const 1) (succ . (foldr max 0) . p2))
+
+nodes :: Exp a a -> [a]
+nodes = cataExp (either singl g) where g = cons . (id >< concat)
+
+graph :: Exp (a, b) (c, d) -> Exp a c
+graph = bmap fst fst
+
+-- (5) Graphics (DOT / HTML) ---------------------------------------------------
+
+cExp2Dot :: Exp (Maybe String) (Maybe String) -> String
+cExp2Dot x = beg ++ main (deco x) ++ end where
+     main b = concat $ (map f . nodes) b  ++ (map g . lnks . graph) b
+     beg = "digraph G {\n    /* edge [label=0]; */\n    graph [ranksep=0.5];\n"
+     end = "}\n"
+     g(k1,k2) = "    " ++ show k1 ++ " -> " ++ show k2 ++ "[arrowhead=none];\n"
+     f(k,Nothing) = "    " ++ show k ++ " [shape=plaintext, label=\"\"];\n"
+     f(k,Just s) = "    " ++ show k ++ " [shape=circle, style=filled, fillcolor=\"#FFFF00\", label=\"" ++ s ++ "\"];\n"
+
+dotpict t = do { writeFile "_.dot" (cExp2Dot t) ; system "open _.dot" }
+
+exp2Html n (Var v) = [ LCell v n 1 ]
+exp2Html n (Term o l) = g (expWidth (Term o l)) o (map (exp2Html (n-1)) l)
+                        where g i o k = [ ICell o 1 i ] ++ (foldr (++) [] k)
+
+expDisplay :: FilePath -> Exp String String -> IO ()
+expDisplay fn = writeFile fn . exp2txt
+
+exp2txt = concat . txtFlat . (html2Txt Str) .  (uncurry exp2Html . (split expDepth id))
+
+type Html a = [ Cell a ]
+
+data Cell a = ICell a Int Int | LCell a Int Int deriving Show
+
+data Txt = Str String | Blk [ Txt ] deriving Show
+
+inds :: [a] -> [Int]
+inds [] = []
+inds (h:t) = inds t ++ [succ (length t)]
+
+seq2ff :: [a] -> [(Int,a)]
+seq2ff = (uncurry zip) . (split inds id)
+
+ff2seq m = map p2 m
+
+txtFlat :: Txt -> [[Char]]
+txtFlat (Str s) = [s]
+txtFlat (Blk []) = []
+txtFlat (Blk (a:l)) = txtFlat a ++ txtFlat (Blk l)
+
+html2Txt :: (a -> Txt) -> Html a -> Txt
+html2Txt f = html . table . (foldr g u) 
+             where u = Str "\n</tr>"
+                   g c (Str s) = g c (Blk [Str s])
+                   g (ICell a x y) (Blk b) = Blk ([ cell (f a) x y ] ++ b)
+                   g (LCell a x y) (Blk b) = Blk ([ cell (f a) x y,  Str "\n</tr>\n<tr>"] ++ b)
+                   html t = Blk [ Str("<meta charset=\"utf-8\"/>"++"<html>\n<body bgcolor=\"#F4EFD8\" " ++
+                                        "text=\"#260000\" link=\"#008000\" " ++
+                                        "vlink=\"#800000\">\n"),
+                                   t,
+                                   Str "</html>\n"
+                                 ]
+                   table t = Blk [ Str "<table style=\"border-collapse:collapse;border:0.5px solid black;\" cellpadding=1 cellspacing=0>",
+                               t,
+                               Str "</table>\n"
+                             ]
+                   cell c x y = Blk [ Str("\n<td style=\"border-collapse:collapse;border:0.4px solid black;\" rowspan=" ++
+                                            itoa y ++
+                                            " colspan=" ++
+                                            itoa x ++
+                                            " align=\"left\"" ++
+                                            ">\n"),
+                                       c,
+                                            Str "\n</td>"
+                                     ]
+                   itoa x = show x
+
+-- (6) Monad -------------------------------------------------------------------
+
+muExp  = cataExp (either id (uncurry Term))
+
+-- (7) Auxiliary functions -----------------------------------------------------
+
+class (Show t) => Expclass t where
+      pict :: t -> IO ExitCode
+--------------------------------------------------------------------------------
+instance (Show v, Show o) => Expclass (Exp v o) where
+    pict = expShow "_.html" . bmap show show
+--------------------------------------------------------------------------------
+instance (Show a) => Expclass (BTree a) where
+    pict = expShow "_.html" .  cBTree2Exp . (fmap show)
+
+cBTree2Exp :: BTree a -> Exp [Char] a
+cBTree2Exp = cataBTree (either (const (Var "nil")) h)
+             where h(a,(b,c)) = Term a [b,c] 
+--------------------------------------------------------------------------------
+instance (Show a) => Expclass [a] where
+    pict = expShow "_.html" .  cL2Exp . (fmap show)
+
+cL2Exp [] = Var " "
+cL2Exp l = Term "List" (map Var l)
+
+--------------------------------------------------------------------------------
+instance (Show a) => Expclass (LTree a) where
+    pict = expShow "_.html" .  cLTree2Exp . (fmap show)
+
+cLTree2Exp = cataLTree (either Var h)
+             where h(a,b) = Term "Fork" [a,b] 
+--------------------------------------------------------------------------------
+cFTree2Exp = cataFTree (inExp . (id -|- (id><f))) where f(a,b)=[a,b]
+--------------------------------------------------------------------------------
+lnks :: Exp a a -> [(a, a)]
+lnks (Var n) = []
+lnks (Term n x) = (x >>= lnks) ++ [ (n,m) | Term m _ <- x ] ++ [ (n,m) | Var m <- x ]
+--------------------------------------------------------------------------------
+deco :: Num n => Exp v o -> Exp (n, v) (n, o)
+deco e = fst (st (f e) 0) where
+     f (Var e) = do {n <- get ; put(n+1); return (Var(n,e)) }
+     f (Term o l) = do { n <- get ; put(n+1);
+                         m <- sequence (map f l);
+                         return (Term (n,o) m)
+                       }
+--------------------------------------------------------------------------------
+untar :: (Ord v, Ord o) => [([o], v)] -> [Exp v o]
+untar = a . (base id id untar) . c where
+   a=sort.map inExp -- algebra
+   c=join.(id><collect).sep. map((p2-|-assocr).distl.(outList >< id)) -- coalgebra
+   base a b y = map(b -|- a >< y)
+
+tar = cataExp g where
+   g = either v o
+   v = singl . (split nil id)
+   o = (>>= f ) . lstr
+   f (o,l)=[(o:a,x)|(a,x)<-l]
+
+instance (Ord v, Ord o) => Ord (Exp v o) where
+   Var v <= Var u = v <= u
+   Var v <= Term o x = False
+   Term o x <= Var v = True
+   Term o x <= Term o' x' = o >= o'
+
+{-- instance Ord (Exp String String) where
+   Var v <= Var u = v <= u
+   Var v <= Term o x = False
+   Term o x <= Var v = True
+   Term o x <= Term o' x' = o >= o'
+--}
+-------------------------------------------------------------------------------

cp2223t/FTree.hs

@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -XNPlusKPatterns #-}
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module FTree where
+
+import Cp
+
+-- (1) Datatype definition -----------------------------------------------------
+
+data FTree a c = Unit c | Comp a (FTree a c, FTree a c) deriving Show
+
+inFTree = either Unit (uncurry Comp)
+
+outFTree (Unit c)         = Left c
+outFTree (Comp a (t1,t2)) = Right(a,(t1,t2))
+
+baseFTree f g h  = f -|- (g  >< (h >< h))
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recFTree f = baseFTree id id f
+
+cataFTree a = a . (recFTree (cataFTree a)) . outFTree
+
+anaFTree f = inFTree . (recFTree (anaFTree f) ) . f
+
+hyloFTree a c = cataFTree a . anaFTree c
+
+-- (3) Map ---------------------------------------------------------------------
+
+instance BiFunctor FTree
+         where bmap f g = cataFTree ( inFTree . baseFTree g f id )
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- (4.1) Inversion (mirror) ----------------------------------------------------
+
+invFTree = cataFTree (inFTree . (id -|- id >< swap))
+
+-- (4.2) Counting --------------------------------------------------------------
+
+countFTree = cataFTree (either (const 1) (succ . (uncurry (+)) . p2))
+
+-- (4.3) Flattening ------------------------------------------------------------
+
+flatFTree = cataFTree flt
+
+flt = either singl (cons.(id><conc))
+
+-- (4.4) Generating lists of Booleans ------------------------------------------
+
+genBoolTree = anaFTree gbt
+
+gbt = f where
+   f(0,x)=i1 x
+   f(n+1,x) = i2(x,((n,False:x),(n,True:x)))
+
+genBools = hyloFTree flt gbt
+

cp2223t/LTree.hs

@@ -0,0 +1,228 @@
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module LTree where
+
+import Cp
+import Data.Monoid
+import Control.Applicative
+import List
+
+-- (1) Datatype definition -----------------------------------------------------
+
+data LTree a = Leaf a | Fork (LTree a, LTree a) deriving (Show, Eq, Ord)
+
+inLTree :: Either a (LTree a, LTree a) -> LTree a
+inLTree = either Leaf Fork
+
+outLTree :: LTree a -> Either a (LTree a,LTree a)
+outLTree (Leaf a)       = i1 a
+outLTree (Fork (t1,t2)) = i2 (t1,t2)
+
+baseLTree g f = g -|- f >< f
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recLTree f = baseLTree id f          -- that is:  id -|- (f >< f)
+
+cataLTree g = g . (recLTree (cataLTree g)) . outLTree
+
+anaLTree f = inLTree . (recLTree (anaLTree f) ) . f
+
+hyloLTree f g = cataLTree f . anaLTree g
+
+-- (3) Map ---------------------------------------------------------------------
+
+instance Functor LTree
+         where fmap f = cataLTree ( inLTree . baseLTree f id )
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- (4.0) Inversion (mirror) ----------------------------------------------------
+
+mirrorLTree = cataLTree (inLTree . (id -|- swap))
+
+-- (4.1) Count and depth -------------------------------------------------------
+
+countLTree = cataLTree (either one add)
+
+depth = cataLTree (either one (succ.umax))
+
+-- (4.2) Serialization ---------------------------------------------------------
+
+tips = cataLTree (either singl conc)
+
+-- (4.3) Double factorial ------------------------------------------------------
+
+dfac 0 = 1
+dfac n = hyloLTree (either id mul) dfacd (1,n)
+
+dfacd(n,m) | n==m      = i1 n
+           | otherwise = i2 ((n,k),(k+1,m))
+                            where k = div (n+m) 2
+
+-- (4.4) Double square function ------------------------------------------------
+
+dsq 0 = 0
+dsq n = (cataLTree (either id add) . fmap (\n->2*n-1) . (anaLTree dfacd)) (1,n)
+
+{--
+dsq 0 = 0
+dsq n = (hyloLTree (either id add) (fdfacd nthodd)) (1,n)
+        where   nthodd n = 2*n - 1 
+                fdfacd f (n,m) | n==m  = i1   (f n)
+                               | otherwise = i2   ((n,k),(k+1,m))
+                                        where k = div (n+m) 2
+--}
+
+-- (4.5) Fibonacci -------------------------------------------------------------
+
+fib =  hyloLTree (either one add) fibd
+
+-- where
+
+fibd n | n < 2     = i1   ()
+       | otherwise = i2   (n-1,n-2)
+
+-- (4.6) Merge sort ------------------------------------------------------------
+
+mSort :: Ord a => [a] -> [a]
+mSort [] = []
+mSort l = hyloLTree (either singl merge) lsplit l
+
+--where
+
+-- singl   x = [x]
+
+merge (l,[])                  = l
+merge ([],r)                  = r
+merge (x:xs,y:ys) | x < y     = x : merge(xs,y:ys) 
+                  | otherwise = y : merge(x:xs,ys)
+
+lsplit [x] = i1 x
+lsplit l   = i2 (sep l) where
+     sep []    = ([],[])
+     sep (h:t) = let (l,r) = sep t in (h:r,l)  -- a List cata
+
+{-- pointwise version:
+
+mSort :: Ord a => [a] -> [a]
+mSort [] = []
+mSort [x] = [x]
+mSort l = let (l1,l2) = sep l
+          in merge(mSort l1, mSort l2)
+--}
+
+-- (4.7) Double map (unordered lists) ------------------------------------------
+
+dmap :: (b -> a) -> [b] -> [a]
+dmap f [] = []
+dmap f x = (hyloLTree (either (singl.f) conc) lsplit) x
+
+-- (4.8) Double map (keeps the order) ------------------------------------------
+
+dmap1 :: (b -> a) -> [b] -> [a]
+dmap1 f [] = []
+dmap1 f x = (hyloLTree (either (singl.f) conc) divide) x
+     where divide [x] = i1 x
+           divide l   = i2 (split (take m) (drop m) l) where m = div (length l) 2
+
+-- (4.8) Combinations ----------------------------------------------------------
+
+comb = hyloLTree (either id add) divide
+   where divide(n,k) = if k `elem` [0,n] then i1 1 else i2((n-1,k),(n-1,k-1))
+
+{-- pointwise: comb (n,k) = if k `elem` [0,n] then 1 else comb(n-1,k)+comb(n-1,k-1) --}
+
+-- (5) Monads ------------------------------------------------------------------
+
+instance Monad LTree where
+     return  = Leaf
+     t >>= g = (mu . fmap g) t
+
+mu  :: LTree (LTree a) -> LTree a
+mu  =  cataLTree (either id Fork)
+
+instance Strong LTree
+
+{-- fmap :: (Monad m) => (t -> a) -> m t -> m a
+    fmap f t = do { a <- t ; return (f a) }
+--}
+
+mcataLTree g = k where
+        k (Leaf a) = return(g1 a)
+        k (Fork(x,y)) = do { a <- k x; b <- k y; return(g2(a,b)) }
+        g1 = g . i1
+        g2 = g . i2
+
+-- (6) Going polytipic -------------------------------------------------------
+
+-- natural transformation from base functor to monoid
+tnat :: Monoid c => (a -> c) -> Either a (c, c) -> c
+tnat f = either f (uncurry mappend)
+
+-- monoid reduction 
+
+monLTree f = cataLTree (tnat f)
+
+-- alternative to (4.2) serialization ----------------------------------------
+
+tips' = monLTree singl
+
+-- alternative to (4.1) counting ---------------------------------------------
+
+countLTree' = monLTree (const (Sum 1))
+
+-- distributive law ----------------------------------------------------------
+
+dlLTree :: Strong f => LTree (f a) -> f (LTree a)
+dlLTree = cataLTree (either (fmap Leaf) (fmap Fork .dstr))
+
+-- (7) Zipper ----------------------------------------------------------------
+
+data Deriv a = Dr Bool (LTree a)
+
+type Zipper a = [ Deriv a ]
+
+plug :: Zipper a -> LTree a -> LTree a
+plug [] t = t
+plug ((Dr False l):z) t = Fork (plug z t,l) 
+plug ((Dr True  r):z) t = Fork (r,plug z t)
+
+-- (8) Advanced --------------------------------------------------------------
+
+instance Applicative LTree where
+    pure = return
+    (<*>) = aap
+
+-- (9) Spine representation --------------------------------------------------
+
+roll = inLTree.(id -|- roll>< id).beta.(id><outList')
+
+spinecata g = g . (id -|- (spinecata g)>< id).spineOut
+
+spineOut = beta.(id><outList')
+
+outList' [] = i1()
+outList' x = i2(last x, blast x)
+
+blast = reverse . tail . reverse
+
+inList' = either nil snoc
+
+snoc(a,x)= x++[a]
+
+unroll = (id><inList').alpha.(id -|- unroll>< id).outLTree
+
+alpha :: Either a ((a, t), t1) -> (a, Either () (t1, t))
+alpha(Left a) = (a,Left())
+alpha(Right ((a,ts),t)) = (a,Right(t,ts))
+
+beta :: (a, Either () (t1, t)) -> Either a ((a, t), t1)
+beta(a,Left()) = Left a
+beta(a,Right(t,ts)) = Right ((a,ts),t)
+
+height = cataLTree (either id (uncurry ht)) where ht a b = 1 + (max a b)
+
+---------------------------- end of library ----------------------------------
+

cp2223t/List.hs

@@ -0,0 +1,216 @@
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module List  where
+
+import Cp
+import Data.List
+import Nat hiding (fac)
+
+-- (1) Datatype definition -----------------------------------------------------
+
+--- Haskell lists are already defined, so the following is a dummy, informal declaration:
+--- data [a] = [] | (a : [a])
+
+inList = either nil cons
+
+outList []    = i1 ()
+outList (a:x) = i2(a,x)
+
+baseList g f = id -|- g >< f
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recList  f   = id -|- id >< f                   -- this is F f for this data type
+
+cataList g   = g . recList (cataList g) . outList   
+
+anaList  g   = inList . recList (anaList g) . g
+
+hyloList f g = cataList f . anaList g
+
+-- (3) Map ---------------------------------------------------------------------
+-- NB: already in the Haskell Prelude
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- (4.1) number representation (base b) evaluator ------------------------------
+
+eval b = cataList (either zero (add.(id><(b*))))
+
+-- eval b [] = 0
+-- eval b (x:xs) = x + b * (eval b xs)
+
+-- (4.2) inversion -------------------------------------------------------------
+
+reverse' = cataList (either nil snoc) where snoc(a,l) = l ++ [a]
+
+-- alternatively: snoc = conc . swap . (singl >< id)
+--                       where singl a = [a]
+--                             conc = uncurry (++)
+
+-- (4.3) Look-up function ------------------------------------------------------
+
+lookup :: Eq a => a -> [(a,b)] -> Maybe b
+lookup k = cataList (either nothing aux)
+           where nothing = const Nothing
+                 aux((a,b),r)
+                    | a == k    = Just b
+                    | otherwise = r
+
+-- (4.4) Insertion sort --------------------------------------------------------
+
+iSort :: Ord a => [a] -> [a]
+iSort =  cataList (either nil insert)
+         where insert(x,[])              = [x]
+               insert(x,a:l) | x < a     = [x,a]++l
+                             | otherwise = a:(insert(x,l))
+
+-- also iSort = hyloList (either (const []) insert) outList
+
+-- (4.5) take (cf GHC.List.take) -----------------------------------------------
+
+utake = anaList aux
+         where aux(0,_) = i1()
+               aux(_,[]) = i1()
+               aux(n,x:xs) = i2(x,(n-1,xs))
+
+-- pointwise version:
+-- take 0 _ = []
+-- take _ [] = []
+-- take (n+1) (x:xs) = x : take n xs
+
+-- (4.6) Factorial--------------------------------------------------------------
+
+fac :: Integer -> Integer
+fac = hyloList (either (const 1) mul) natg
+
+natg = (id -|- (split succ id)) . outNat
+
+-- (4.6.1) Factorial (alternative) ---------------------------------------------
+
+fac' = hyloList (either (const 1) (mul . (succ >< id)))
+                 ((id -|- (split id id)) . outNat)
+
+{-- cf:
+
+fac' = hyloList (either (const 1) g) natg'
+       where g(n,m) = (n+1) * m
+             natg' 0 = i1 ()
+             natg' (n+1) = i2 (n,n)
+--}
+
+-- (4.7) Square function -------------------------------------------------------
+
+sq = hyloList summing oddd
+
+summing = either (const 0) add
+
+evens = anaList evend
+
+odds  = anaList oddd
+
+evend = (id -|- (split (2*) id)) . outNat
+
+oddd  = (id -|- (split odd id)) . outNat
+       where odd n = 2*n+1
+
+{-- pointwise:
+sq 0 = 0
+sq (n+1) = 2*n+1 + sq n
+
+cf. Newton's binomial: (n+1)^2 = n^2 + 2n + 1
+--}
+
+-- (4.7.1) Square function reusing anaList of factorial ----------------------------
+
+sq' = (cataList summing) . fmap (\n->2*n-1) . (anaList natg)
+
+-- (4.8) Prefixes and suffixes -------------------------------------------------
+
+prefixes :: Eq a => [a] -> [[a]]
+prefixes = cataList (either (const [[]]) scan)
+           where scan(a,l) = [[]] ++ (map (a:) l)
+
+suffixes = anaList g
+           where g = (id -|- (split cons p2)).outList
+
+diff :: Eq a => [a] -> [a] -> [a]
+diff x l = cataList (either nil (g l)) x
+           where g l (a,x) = if (a `elem` l) then x else (a:x)
+
+-- (4.9) Grouping --------------------------------------------------------------
+
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n = anaList (g n) where
+          g n [] = i1()
+          g n x = i2(take n x,drop n x)
+
+nest = chunksOf
+
+-- (4.10) Relationship with foldr, foldl ----------------------------------------
+
+myfoldr :: (a -> b -> b) -> b -> [a] -> b
+myfoldr f u = cataList (either (const u) (uncurry f))
+
+myfoldl :: (a -> b -> a) -> a -> [b] -> a
+myfoldl f u = cataList' (either (const u) (uncurry f . swap))
+              where cataList' g   = g . recList (cataList' g) . outList'   
+                    outList' [] = i1()
+                    outList' x =i2(last x, blast x)
+                    blast = tail . reverse
+
+-- (4.11) No repeats ------------------------------------------------------------
+
+nr :: Eq a => [a] -> Bool
+nr = p2 . aux where
+     aux = cataList (either f (split g h))
+     f _ = ([],True)
+     g(a,(t,b)) = a:t
+     h(a,(t,b)) = not(a `elem` t) && b
+
+-- (4.12) Advanced --------------------------------------------------------------
+
+-- (++) as a list catamorphism ------------------------------------------------
+
+ccat :: [a] -> [a] -> [a]
+ccat = cataList (either (const id) compose). map (:) where
+       -- compose(f,g) = f.g
+       compose =  curry(ap.(id><ap).assocr)
+
+-- monadic map
+-- mmap f = cataList $ either (return.nil)(fmap cons.dstr.(f><id))
+mmap f [] = return []
+mmap f (h:t) = do { b <- f h ; x <- mmap f t ; return (b:x) }
+
+-- distributive law
+lam  :: Strong m => [m a] -> m [a]
+lam = cataList ( either (return.nil)(fmap cons.dstr) )
+
+-- monadic catas
+
+mcataList :: Strong ff => (Either () (b, c) -> ff c) -> [b] -> ff c
+mcataList g = g .! (dl . recList (mcataList g) . outList)   
+
+dl :: Strong m => Either () (b, m a) -> m (Either () (b, a))
+dl = either (return.i1)(fmap i2. lstr)
+
+--lam' = mcataList (either (return.nil)(fmap cons.rstr))
+
+-- streaming -------------------------------------------------------------------
+
+stream f g c x = case f c of
+   Just (b, c') -> b : stream f g c' x
+   Nothing      ->  case x of
+                      a:x' -> stream f g (g c a) x'
+                      []   -> []
+
+-- heterogeneous lists ---------------------------------------------------------
+
+join :: ([a], [b]) -> [Either a b]
+join (a, b) = map i1 a ++ map i2 b
+
+sep = split s1 s2 where
+   s1 []=[]; s1(Left a:x) = a:s1 x; s1(Right b:x)=s1 x
+   s2 []=[]; s2(Left a:x) = s2 x; s2(Right b:x)=b:s2 x
+---- end of List.hs ------------------------------------------------------------

cp2223t/ListUtils.hs

@@ -0,0 +1,26 @@
+module ListUtils where
+
+
+-- create a singleton list
+-- 
+singleton :: a -> [a]
+singleton x = [x]
+
+
+-- create a list of length n
+-- 
+--replicate :: Int -> a -> [a]
+--replicate n x = take n (repeat x)
+
+
+-- apply a function to the nth element of a list
+-- 
+onNth :: Int -> (a -> a) -> [a] -> [a]
+-- onNth n f xs | n<1 = xs
+-- onNth 1 f (x:xs)   = f x:xs
+-- onNth n f (x:xs)   = x:onNth (n-1) f xs
+
+onNth n f xs | n<1 = xs
+onNth n f xs = case splitAt (n-1) xs of
+                 (ys,[])    -> ys
+                 (ys,z:zs') -> ys++f z:zs' 

cp2223t/Makefile

@@ -0,0 +1,17 @@
+NAME = cp2223t
+
+quick:
+	lhs2TeX $(NAME).lhs > $(NAME).tex
+	pdflatex $(NAME).tex
+	open $(NAME).pdf
+
+full:
+	lhs2TeX $(NAME).lhs > $(NAME).tex
+	pdflatex $(NAME).tex
+	bibtex $(NAME)
+	makeindex $(NAME)
+	pdflatex $(NAME).tex
+	open $(NAME).pdf
+
+clean:
+	rm -f $(NAME).tex $(NAME).out $(NAME).aux $(NAME).bbl $(NAME).blg $(NAME).log $(NAME).ptb

cp2223t/NEList.hs

@@ -0,0 +1,49 @@
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module NEList where
+
+import Cp
+
+-- (1) Datatype definition -----------------------------------------------------
+
+-- data [a] = a | (:) a ( a) deriving Show
+
+inl = either singl (uncurry (:))
+
+out [a]   = Left a
+out (a:x) = Right(a,x)
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+base g f = g -|- (g >< f)
+
+rec f = base id f
+
+cata g = g . rec (cata g) . out   
+
+ana g = inl . (rec (ana g) ) . g
+
+hylo h g = cata h . ana g
+
+
+-- (3) Examples ----------------------------------------------------------------
+
+concatg ([],ys) = i1 ys
+concatg (x:xs,ys) = i2([x],(xs,ys))
+
+concath = either id f
+          where f([a],l) = a:l
+
+glast = cata (either id p2)
+
+{--
+merge (l,[])                  = l
+merge ([],r)                  = r
+merge (x:xs,y:ys) | x < y     = x : merge(xs,y:ys)
+                  | otherwise = y : merge(x:xs,ys)
+--}
+mrg (l,[])                  = i1 l
+mrg ([],r)                  = i1 r
+mrg (x:xs,y:ys) | x < y     = i2(x,(xs,y:ys))
+                | otherwise = i2(y,(x:xs,ys))

cp2223t/Nat.hs

@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -XNPlusKPatterns #-}
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module Nat where
+
+import Cp
+
+-- (1) Datatype definition -----------------------------------------------------
+
+-- "data Nat = 0 | succ Nat"   -- in fact: Haskell Integer is used as carrier type
+
+inNat = either (const 0) succ
+
+outNat 0 = i1 ()
+outNat (n+1) = i2 n
+
+-- NB: inNat and outNat are isomorphisms only if restricted to non-negative integers
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recNat f    = id -|- f                                 -- this is F f for this datatype
+
+cataNat g   = g . recNat (cataNat g) . outNat
+
+anaNat h    = inNat . (recNat (anaNat h) ) . h
+
+hyloNat g h = cataNat g . anaNat h
+
+-- paraNat g   = g . recNat (split id (paraNat g)) . outNat
+
+-- (3) Map ---------------------------------------------------------------------
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- (4.1) for is the "fold" of natural numbers
+
+for b i = cataNat (either (const i) b)
+
+somar a = cataNat (either (const a) succ)        -- for succ a
+
+multip a = cataNat (either (const 0) (a+))       -- for (a+) 0
+
+exp a = cataNat (either (const 1) (a*))          -- for (a*) 1
+
+-- (4.2) sq (square of a natural number) 
+
+sq 0 = 0
+sq (n+1) = oddn n + sq n where oddn n = 2*n+1
+
+-- sq = paraNat (either (const 0) g)i
+
+sq' = p1 . aux
+       -- this is the outcome of calculating sq as a for loop using the
+       -- mutual recursion law
+      where aux = cataNat (either (split (const 0)(const 1)) (split (uncurry (+))((2+).p2)))
+
+sq'' n  = -- the same as a for loop (putting variables in)
+       p1 (for body (0,1) n)
+       where body(s,o) = (s+o,2+o)
+
+-- (4.3) factorial
+
+fac = p2. facfor
+facfor = for (split (succ.p1) mul) (1,1) 
+
+-- factorial = paraNat (either (const 1) g) where g(n,r) = (n+1) * r
+
+-- (4.4) integer division as an anamorphism --------------
+
+idiv :: Integer -> Integer -> Integer
+{-- pointwise
+x `idiv` y  |   x <  y    = 0
+            |   x >= y    = (x - y) `idiv` y + 1
+--}
+
+idiv = flip aux
+
+aux y = anaNat divide where 
+           divide x | x <  y  = i1 ()
+                    | x >= y  = i2 (x - y)
+
+--- (4.5) bubble sort -----------------------------------
+
+bSort xs = for bubble xs (length xs) where
+   bubble (x:y:xs)
+       | x > y = y : bubble (x:xs)
+       | otherwise = x : bubble (y:xs)
+   bubble x = x
+
+--- (5) While loop -------------------------------------
+
+{-- pointwise 
+
+while p f x | not (p x) = x
+              | otherwise = while p f (f x)
+--}
+
+while :: (a -> Bool) -> (a -> a) -> a -> a
+while p f = w where w =  (either id id) . (w -|- id) . (f -|- id) . (grd p)
+
+--- (5) Monadic for -------------------------------------
+
+mfor b i 0 = i
+mfor b i (n+1) = do {x <- mfor b i n ; b x}
+
+--- end of Nat.hs ----------------------------------------

cp2223t/Probability.hs

@@ -0,0 +1,697 @@
+
+-- Credits: Erwig, Martin and Kollmannsberger, Steve
+--          FUNCTIONAL PEARLS: Probabilistic functional programming in Haskell,
+--          JFP, 2006
+--          DOI: 10.1017/S0956796805005721
+
+module Probability where
+
+import qualified System.Random
+import Data.List (sort,sortBy,transpose)
+import Control.Monad
+import System.IO.Unsafe (unsafePerformIO)
+
+import ListUtils
+import Show
+
+{- TO DO:
+
+* create export list
+
+* extend Dist by a constructor for continuous distributions:
+
+  C (Float -> Float)
+
+* prove correctness of |||
+
+-}
+
+--------- jno (to be checked) --------------
+import Control.Applicative
+instance Applicative Dist where
+    pure = return
+    (<*>) = ap
+
+instance Alternative Dist where
+    empty = D []
+    (<|>) = (>>)
+--------- end jno --------------------------
+
+
+------------------------------------------------------------------------------
+-- CONTENTS:
+--
+-- 0 AUXILIARY DEFINITIONS
+-- 1 DETERMINISTIC AND PROBABILISTIC VALUES
+-- 2 RANDOMIZED VALUES
+-- 3 DETERMINISTIC AND PROBABILISTIC GENERATORS
+-- 4 RANDOMIZED GENERATORS
+-- 5 ITERATORS AND SIMULATORS
+-- 6 TRACING
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- 0 AUXILIARY DEFINITIONS
+--
+--   Event
+--   Probability
+------------------------------------------------------------------------------
+
+-- 
+-- Events
+-- 
+type Event a = a -> Bool
+
+oneOf :: Eq a => [a] -> Event a
+oneOf = flip elem
+
+just :: Eq a => a -> Event a
+just = oneOf . singleton
+
+
+-- 
+-- Probabilities
+-- 
+newtype Probability = P ProbRep
+
+type ProbRep = Float
+
+precision :: Int
+precision = 1
+
+showPfix :: ProbRep -> String
+showPfix f | precision==0 = showR 3 (round (f*100))++"%"
+           | otherwise    = showR (4+precision) (fromIntegral (round (f*100*d))/d)++"%"
+             where d = 10^precision
+
+-- -- mixed precision
+-- -- 
+-- showP :: ProbRep -> String
+-- showP f | f>=0.1    = showR 3 (round (f*100))++"%"
+--         | otherwise = show (f*100)++"%"
+ 
+-- fixed precision
+-- 
+showP :: ProbRep -> String
+showP = showPfix
+
+
+instance Show Probability where
+  show (P p) = showP p
+
+errorMargin :: ProbRep
+errorMargin = 0.00001
+
+
+--
+-- Monad composition
+--
+--  (>@>)  binary composition
+--  sequ   composition of a list of monadic functions
+--  
+(>@>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
+f >@> g = (>>= g) . f
+
+sequ :: Monad m => [a -> m a] -> a -> m a
+sequ = foldl (>@>) return
+
+
+
+------------------------------------------------------------------------------
+-- 1 DETERMINISTIC AND PROBABILISTIC VALUES
+--
+--   Dist     probability disribution
+--   Spread   functions to convert a list of values into a distribution
+------------------------------------------------------------------------------
+
+-- 
+-- Distributions
+-- 
+newtype Dist a = D {unD :: [(a,ProbRep)]}
+
+instance Monad Dist where
+  return x = D [(x,1)]
+  d >>= f  = D [(y,q*p) | (x,p) <- unD d, (y,q) <- unD (f x)]
+
+
+-- note: mzero is a zero for >>= and a unit for mplus
+-- 
+instance MonadPlus Dist where
+  mzero      = D []
+  mplus d d' | isZero d || isZero d' = mzero
+             | otherwise             = unfoldD $ choose 0.5 d d' 
+
+isZero :: Dist a -> Bool
+isZero (D d) = null d
+
+
+instance Functor Dist where
+  fmap f (D d) = D [(f x,p) | (x,p) <- d]
+
+instance (Ord a,Eq a) => Eq (Dist a) where
+  D xs == D ys = map fst (norm' xs)==map fst (norm' ys) && 
+                   all (\((_,p),(_,q))->abs (p-q)<errorMargin) (zip (norm' xs) (norm' ys))
+
+
+-- auxiliary functions for constructing and working with distributions
+-- 
+onD :: ([(a,ProbRep)] -> [(a,ProbRep)]) -> Dist a -> Dist a
+onD f  = D . f . unD
+
+sizeD :: Dist a -> Int
+sizeD = length . unD
+
+checkD :: Dist a -> Dist a
+checkD (D d) | abs (1-sumP d) < errorMargin = D d
+             | otherwise = error ("Illegal distribution: total probability = "++show (sumP d))
+
+mkD :: [(a,ProbRep)] -> Dist a
+mkD = checkD . D
+
+sumP :: [(a,ProbRep)] -> ProbRep
+sumP = sum . map snd
+
+sortP :: [(a,ProbRep)] -> [(a,ProbRep)]
+sortP = sortBy (\x y->compare (snd y) (snd x))
+
+
+-- normalization = grouping
+-- 
+normBy ::  Ord a => (a -> a -> Bool) ->  Dist a -> Dist a
+normBy f = onD $ accumBy f . sort
+
+accumBy :: Num b => (a -> a -> Bool) -> [(a,b)] -> [(a,b)]
+accumBy f ((x,p):ys@((y,q):xs)) | f x y     = accumBy f ((x,p+q):xs)
+                                | otherwise = (x,p):accumBy f ys
+accumBy _ xs = xs
+
+norm ::  Ord a => Dist a -> Dist a
+norm = normBy (==)
+
+norm' :: Ord a => [(a,ProbRep)] -> [(a,ProbRep)]
+norm' = accumBy (==) . sort
+
+
+-- pretty printing
+-- 
+instance (Ord a,Show a) => Show (Dist a) where
+  show (D []) = "Impossible"
+  show (D xs) = concatMap (\(x,p)->showR w x++' ':showP p++"\n") (sortP (norm' xs))
+                where w = maximum (map (length.show.fst) xs)
+
+
+--
+-- Operations on distributions
+-- 
+
+-- product of independent distributions
+-- 
+joinWith :: (a -> b -> c) -> Dist a -> Dist b -> Dist c
+joinWith f (D d) (D d') = D [ (f x y,p*q) | (x,p) <- d, (y,q) <- d']
+
+prod :: Dist a -> Dist b -> Dist (a,b)
+prod = joinWith (,)
+
+
+-- distribution generators
+-- 
+type Spread a = [a] -> Dist a
+
+certainly :: Trans a
+certainly = return 
+
+impossible :: Dist a
+impossible = mzero
+
+choose :: ProbRep -> a -> a -> Dist a
+choose p x y = enum [p,1-p] [x,y]
+
+enum :: [ProbRep] -> Spread a
+enum ps xs = mkD $ zip xs ps
+
+enumPC :: [ProbRep] -> Spread a
+enumPC ps = enum (map (/100) ps)
+
+relative :: [Int] -> Spread a
+relative ns = enum (map (\n->fromIntegral n/fromIntegral (sum ns)) ns)
+
+shape :: (Float -> Float) -> Spread a
+shape _ [] = impossible
+shape f xs = scale (zip xs ps)
+             where incr = 1 / fromIntegral ((length xs) - 1)
+                   ps = map f (iterate (+incr) 0)
+
+linear :: Float -> Spread a
+linear c = shape (c*)
+
+uniform :: Spread a
+uniform = shape (const 1)
+
+negexp :: Spread a
+negexp = shape (\x -> exp (-x))
+
+normal :: Spread a
+normal = shape (normalCurve 0.5 0.5)
+
+normalCurve :: Float -> Float -> Float -> Float
+normalCurve mean stddev x = 1 / sqrt (2 * pi) * exp (-1/2 * u^2)
+        where u = (x - mean) / stddev
+
+
+-- extracting and mapping the domain of a distribution
+-- 
+extract :: Dist a -> [a]
+extract = map fst . unD
+
+mapD :: (a -> b) -> Dist a -> Dist b
+mapD = fmap
+
+
+-- unfold a distribution of distributions into one distribution
+-- 
+unfoldD :: Dist (Dist a) -> Dist a
+unfoldD (D d) = D [ (x,p*q) | (d',q) <- d, (x,p) <- unD d' ]
+
+
+-- conditional distribution
+-- 
+cond :: Dist Bool -> Dist a -> Dist a -> Dist a
+cond b d d' = unfoldD $ choose p d d'
+              where P p = truth b
+
+truth :: Dist Bool -> Probability
+truth (D ((b,p):_)) = P (if b then p else 1-p)
+
+
+-- conditional probability
+-- 
+(|||) :: Dist a -> Event a -> Dist a
+(|||) = flip filterD
+
+
+-- filtering distributions
+--  
+data Select a = Case a | Other
+                deriving (Eq,Ord,Show)
+
+above :: Ord a => ProbRep -> Dist a -> Dist (Select a)
+above p (D d) = D (map (\(x,q)->(Case x,q)) d1++[(Other,sumP d2)])
+                where (d1,d2) = span (\(_,q)->q>=p) (sortP (norm' d))
+
+scale :: [(a,ProbRep)] -> Dist a
+scale xs = D (map (\(x,p)->(x,p/q)) xs)
+           where q = sumP xs
+                    
+filterD :: (a -> Bool) -> Dist a -> Dist a
+filterD p = scale . filter (p . fst) . unD
+
+
+-- selecting from distributions
+-- 
+selectP :: Dist a -> ProbRep -> a
+selectP (D d) p = scanP p d
+
+scanP :: ProbRep -> [(a,ProbRep)] -> a
+scanP p ((x,q):ps) | p<=q || null ps = x
+                   | otherwise       = scanP (p-q) ps
+
+infix 8 ??
+
+(??) :: Event a -> Dist a -> Probability
+(??) p = P . sumP . filter (p . fst) . unD
+
+ 
+-- TO DO: generalize Float to arbitrary Num type
+-- 
+class ToFloat a where
+  toFloat :: a -> Float
+ 
+instance ToFloat Float   where toFloat = id
+instance ToFloat Int     where toFloat = fromIntegral
+instance ToFloat Integer where toFloat = fromIntegral
+
+class FromFloat a where
+  fromFloat :: Float -> a
+
+instance FromFloat Float   where fromFloat = id
+instance FromFloat Int     where fromFloat = round
+instance FromFloat Integer where fromFloat = round
+  
+-- expected :: ToFloat a => Dist a -> Float
+-- expected = sum . map (\(x,p)->toFloat x*p) . unD
+
+class Expected a where
+  expected :: a -> Float
+
+-- instance ToFloat a => Expected a where
+--   expected = toFloat
+instance Expected Float   where expected = id
+instance Expected Int     where expected = toFloat
+instance Expected Integer where expected = toFloat
+
+instance Expected a => Expected [a] where
+  expected xs = sum (map expected xs) / toFloat (length xs)
+
+instance Expected a => Expected (Dist a) where
+  expected = sum . map (\(x,p)->expected x*p) . unD
+
+instance Expected a => Expected (IO a) where
+  expected r = expected (System.IO.Unsafe.unsafePerformIO r)
+
+
+-- statistical analyses
+-- 
+variance :: Expected a => Dist a -> Float
+variance d@(D ps) = sum $ map (\(x,p)->p*sqr (expected x - ex)) ps
+   where sqr x = x * x 
+         ex    = expected d
+
+stddev :: Expected a => Dist a -> Float
+stddev = sqrt . variance
+
+
+
+------------------------------------------------------------------------------
+-- 2 RANDOMIZED VALUES
+--
+--   R         random value
+--   RDist     random distribution
+------------------------------------------------------------------------------
+
+
+--
+-- Random values
+--
+type R a = IO a
+
+printR :: Show a => R a -> R ()
+printR = (>>= print) 
+
+instance Show (IO a) where
+  show _ = ""
+
+pick :: Dist a -> R a
+-- pick d = do {p <- Random.randomRIO (0,1); return (selectP p d)}
+pick d = System.Random.randomRIO (0,1) >>= return . selectP d
+
+
+--
+-- Randomized distributions
+--
+type RDist a = R (Dist a)
+
+rAbove :: Ord a => ProbRep -> RDist a -> RDist (Select a)
+rAbove p rd = do D d <- rd
+                 let (d1,d2) = span (\(_,q)->q>=p) (sortP (norm' d))
+                 return (D (map (\(x,q)->(Case x,q)) d1++[(Other,sumP d2)]))
+
+
+
+------------------------------------------------------------------------------
+-- 3 DETERMINISTIC AND PROBABILISTIC GENERATORS
+--
+--   Change    deterministic generator
+--   Trans     probabilistic generator
+--   SpreadC   functions to convert a list of changes into a transition
+--   SpreadT   functions to convert a list of transitions into a transition
+------------------------------------------------------------------------------
+
+-- 
+-- transitions
+-- 
+type Change a = a -> a
+
+type Trans a = a -> Dist a
+
+idT :: Trans a
+idT = certainlyT id
+
+
+-- mapT maps a change function to the result of a transformation
+-- (mapT is somehow a lifted form of mapD)
+-- The restricted type of f results from the fact that the
+-- argument to t cannot be changed to b in the result Trans type.
+-- 
+mapT :: Change a -> Trans a -> Trans a
+mapT f t = mapD f . t
+
+
+-- unfold a distribution of transitions into one transition
+-- 
+--   NOTE: The argument transitions must be independent
+-- 
+unfoldT :: Dist (Trans a) -> Trans a
+unfoldT (D d) x = D [ (y,p*q) | (f,p) <- d, (y,q) <- unD (f x) ]
+
+
+-- spreading changes into transitions
+-- 
+type SpreadC a = [Change a] -> Trans a
+
+certainlyT :: Change a -> Trans a
+certainlyT f = certainly . f
+-- certainlyT = (certainly .)
+-- certainlyT = maybeC 1
+
+maybeT :: ProbRep -> Change a -> Trans a
+maybeT p f = enumT [p,1-p] [f,id]
+
+liftC :: Spread a -> [Change a] -> Trans a
+liftC s cs x = s [f x | f <- cs]
+-- liftC s cs x = s $ map ($ x) cs
+
+uniformT  = liftC uniform
+normalT   = liftC normal
+linearT c = liftC (linear c)
+enumT xs  = liftC (enum xs)
+
+
+-- spreading transitions into transitions
+-- 
+type SpreadT a = [Trans a] -> Trans a
+
+liftT :: Spread (Trans a) -> [Trans a] -> Trans a
+liftT s = unfoldT . s
+
+uniformTT  = liftT uniform
+normalTT   = liftT normal
+linearTT c = liftT (linear c)
+enumTT xs  = liftT (enum xs)
+
+ 
+
+------------------------------------------------------------------------------
+-- 4 RANDOMIZED GENERATORS
+--
+--   RChange   random change
+--   RTrans    random transition
+------------------------------------------------------------------------------
+
+
+--
+-- Randomized changes
+--
+type RChange a = a -> R a
+
+random :: Trans a -> RChange a
+random t = pick . t
+-- random = (pick .)
+
+
+--
+-- Randomized transitions
+--
+type RTrans a = a -> RDist a
+type ApproxDist a = R [a]
+
+
+-- rDist converts a list of randomly generated values into
+--       a distribution by taking equal weights for all values
+--       
+rDist :: Ord a => [R a] -> RDist a
+rDist = fmap (norm . uniform) . sequence
+
+
+
+------------------------------------------------------------------------------
+-- 5 ITERATION AND SIMULATION
+--
+-- Iterate   class defining *. 
+-- Sim       class defining ~.
+------------------------------------------------------------------------------
+
+{-
+
+Naming convention:
+
+*   takes n :: Int and a generator and iterates the generator n times
+.   produces a single result
+..  produces a trace
+~   takes k :: Int [and n :: Int] and a generator and simulates 
+    the [n-fold repetition of the] generator k times
+
+n *.  t   iterates t and produces a distribution
+n *.. t   iterates t and produces a trace
+
+k     ~.  t   simulates t and produces a distribution
+(k,n) ~*. t   simulates the n-fold repetition of t and produces a distribution
+(k,n) ~.. t   simulates the n-fold repetition of t and produces a trace
+
+-}
+
+-- Iteration captures three iteration strategies:
+-- iter builds an n-fold composition of a (randomized) transition 
+-- while and until implement conditional repetitions
+--
+-- The class Iterate allows the overloading of iteration for different
+-- kinds of generators, namely transitions and random changes:
+-- 
+--   Trans   a = a -> Dist a    ==>   c = Dist
+--   RChange a = a -> R a       ==>   c = R = IO
+-- 
+class Iterate c where
+  (*.)  :: Int -> (a -> c a) -> (a -> c a)
+  while :: (a -> Bool) -> (a -> c a) -> (a -> c a)
+  until :: (a -> Bool) -> (a -> c a) -> (a -> c a)
+  until p = while (not.p)
+
+infix 8 *.
+
+-- iteration of transitions
+-- 
+instance Iterate Dist where
+  n *. t = head . (n *.. t)
+  while p t x = if p x then t x >>= while p t else certainly x
+
+-- iteration of random changes
+-- 
+instance Iterate IO where
+  n *. r = (>>= return . head) . rWalk n r
+  while p t x = do {l <- t x; if p l then while p t l else return l}
+
+
+
+-- Simulation means to repeat a random chage many times and
+-- to accumulate all results into a distribution. Therefore,
+-- simulation can be regarded as an approximation of distributions
+-- through randomization.
+--
+-- The Sim class contains two functions: 
+-- 
+--   ~.   returns the final randomized transition 
+--   ~..  returns the whole trace
+-- 
+-- The Sim class allows the overloading of simulation for different
+-- kinds of generators, namely transitions and random changes:
+-- 
+--   Trans   a = a -> Dist a   ==>   c = Dist
+--   RChange a = a -> R a      ==>   c = R = IO
+-- 
+class Sim c where 
+  (~.)  :: Ord a => Int       -> (a -> c a) -> RTrans a
+  (~..) :: Ord a => (Int,Int) -> (a -> c a) -> RExpand a
+  (~*.) :: Ord a => (Int,Int) -> (a -> c a) -> RTrans a
+
+infix 6 ~.
+infix 6 ~..
+
+-- simulation for transitions
+-- 
+instance Sim Dist where
+  (~.)  x = (~.)  x . random
+  (~..) x = (~..) x . random
+  (~*.) x = (~*.) x . random
+ 
+
+-- simulation for random changes
+-- 
+instance Sim IO where  
+  (~.)     n  t = rDist . replicate n . t
+  (~..) (k,n) t = mergeTraces . replicate k . rWalk n t
+  (~*.) (k,n) t = k ~. n *. t
+
+infix 8 ~*.
+
+--(~*.) :: (Iterate c,Sim c,Ord a) => (Int,Int) -> (a -> c a) -> RTrans a
+--(k,n) ~*. t = 
+
+
+------------------------------------------------------------------------------
+-- 7 TRACING
+--
+--   (R)Trace
+--   (R)Space
+--   (R)Walk
+--   (R)Expand
+------------------------------------------------------------------------------
+
+type Trace a  = [a]
+type Space a  = Trace (Dist a)
+type Walk a   = a -> Trace a
+type Expand a = a -> Space a
+
+
+-- >>: composes the result of a transition with a space 
+-- (transition is composed on the left)
+-- 
+-- (a -> m a) -> (a -> [m a]) -> (a -> [m a])
+(>>:) :: Trans a -> Expand a -> Expand a
+f >>: g = \x -> let ds@(D d:_)=g x in
+                    D [ (z,p*q) | (y,p) <- d, (z,q) <- unD (f y)]:ds
+
+infix 6 >>:
+
+-- walk is a bounded version of the predefined function iterate
+-- 
+walk :: Int -> Change a -> Walk a
+walk n f = take n . iterate f
+
+-- *.. is identical to *., but returns the list of all intermediate
+--     distributions
+--     
+(*..) :: Int -> Trans a -> Expand a
+0 *.. _ = singleton . certainly
+1 *.. t = singleton . t
+n *.. t = t >>: (n-1) *.. t
+
+infix 8 *..
+
+
+type RTrace a  = R (Trace a)
+type RSpace a  = R (Space a)
+type RWalk a   = a -> RTrace a
+type RExpand a = a -> RSpace a
+
+--          (a -> m a) -> (a -> m [a]) -> (a -> m [a])
+composelR :: RChange a -> RWalk a -> RWalk a
+composelR f g x = do {rs@(r:_) <- g x; s <- f r; return (s:rs)}
+
+
+-- rWalk computes a list of values by
+--       randomly selecting one value from a distribution in each step.
+-- 
+rWalk :: Int -> RChange a -> RWalk a
+rWalk 0 _ = return . singleton
+rWalk 1 t = (>>= return . singleton) . t
+rWalk n t = composelR t (rWalk (n-1) t)
+
+
+-- mergeTraces converts a list of RTraces, into a list of randomized 
+--             distributions, i.e., an RSpace, by creating a randomized
+--             distribution for each list position across all traces
+--
+mergeTraces :: Ord a => [RTrace a] -> RSpace a
+mergeTraces = fmap (zipListWith (norm . uniform)) . sequence
+              where
+                zipListWith :: ([a] -> b) -> [[a]] -> [b]
+                zipListWith f = map f . transpose
+
+{-
+
+LAWS
+
+  const . pick = random . const
+
+-}
+

cp2223t/RelCalc.hs

@@ -0,0 +1,209 @@
+{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}
+
+-- (c) CP/MFP (2007/2022)
+
+module RelCalc where
+
+import Data.List
+import Cp hiding (tot)
+
+--- composition (left to right to be consistent with Alloy) ----
+
+comp :: (Eq b, Ord a, Ord c) => [(a, b)] -> [(b, c)] -> [(a, c)]
+comp m n = set [ (a,c) | (a,b) <- m, (b',c) <- n, b==b' ]
+
+--- converse
+
+conv :: (Ord b, Ord a) => [(a, b)] -> [(b, a)]
+conv = smap swap
+
+--- composition with a function
+
+fcomp r f = smap (id><f) r
+
+lcomp f s = conv(conv s `fcomp` f)
+
+--- relational inclusion
+
+sse r s = all ((flip elem) s) r  -- sse: subset or equal
+
+atmost = sse
+
+--- union and intersection
+
+inter s r = set (intersect s r) 
+
+runion s r = set (union s r) 
+
+--- kernel and image
+
+ker r = r `comp` (conv r)
+
+img r = conv r `comp` r
+
+--- coreflexives
+
+crflx :: Ord c => [c] -> [(c, c)]
+crflx = smap (split id id)
+
+point :: Ord c => c -> [(c, c)]
+point = crflx . singl
+
+-- domain and range
+
+dom :: Ord a => [(a, b)] -> [a]
+dom = smap p1
+
+rng :: Ord b => [(a, b)] -> [b]
+rng = smap p2
+
+rho = crflx . rng
+
+delta = rho . conv
+
+-- properties of relations 
+
+coreflexive = all (uncurry(==))
+
+injective = simple . conv
+
+simple :: (Ord b, Ord a) => [(a, b)] -> Bool
+simple = coreflexive . img
+
+consistent m n = coreflexive (conv m `comp` n)
+
+-- restriction operators
+
+domr :: (Ord a, Ord t) => [a] -> [(a, t)] -> [(a, t)] -- domain restrict
+domr s r = (crflx s) `comp` r
+
+doms s r = r \\ (domr s r)  -- domain subtract
+
+r.-.s = doms (dom s) r
+
+-- relation overriding
+
+plus :: (Ord a, Ord t) => [(a, t)] -> [(a, t)] -> [(a, t)]
+plus m n = runion (drminus (dom n) m) n
+
+drminus s r = domr (sdiff (dom r) s) r
+
+drplus  s r = domr (inter (dom r) s) r
+
+-- relation coproduct
+
+reither a b =  (set.conv) (runion (conv a `fcomp` i1) (conv b `fcomp` i2))
+
+unreither r = (a,b) where
+     a = set [(x,y) | (Left x,y) <- r]
+     b = set [(x,y) | (Right x,y) <- r]
+
+-- pairing
+
+rjoin r s = discollect $ smap (id><dstr) $ meet (collect r)(collect s) where dstr(y,x) = nub [(b,a) | b <- y, a <- x]
+
+meet m n = [  k |-> (pap m k, pap n k) | k <- inter (dom m) (dom n)]  -- assumes m and n simple
+
+rzipWith f a b = (rjoin a b `fcomp` f)
+
+-- relation 'currying'
+
+unvec = smap f where f(a,(c,b)) = ((a,b),c)
+
+vec   = smap f where f((a,b),c) = (a,(c,b))
+
+-- constant relation on a set
+
+pconst k s = smap (split id (const k)) s
+
+--- power transpose
+
+pT = flip tot [] . collect  -- power transpose
+
+collect :: (Ord b, Ord a) => [(b, a)] -> [(b, [a])]
+collect x = set [ k |-> set [ d' | (k',d') <- x , k'==k ] | (k,d) <- x ]
+
+-- Maybe transpose (assumes simplicity)
+
+mT :: Eq a => [(a, b)] -> a -> Maybe b
+mT = flip lookup
+
+pap :: Eq a => [(a, t)] -> a -> t
+pap m = unJust . (mT m) where unJust (Just a) = a -- partial inspector of simple relation A->B
+
+-- tot m b a = if a `elem` dom m then pap m a else b -- total inspector of simple relation A->B
+tot m b = maybe b id . mT m
+
+-- tap m a = if a `elem` dom m then pap m a else a -- total inspector of simple relation, A->A
+tap m a = tot m a a
+
+condid p f = cond p f id
+
+pmap = map . pap -- mapping a simple relation
+
+idx x = pap (zip x [0..])
+ 
+--- sets modelled by sorted, repeat-free lists (naive but useful)
+
+set = sort . nub
+
+card = length . set 
+
+smap :: Ord a => (b -> a) -> [b] -> [a]
+smap f = set . (map f)
+
+--- histograms and distributions
+
+hist :: Eq a => [a] -> [(a, Int)]
+hist l = nub [ (x, count x l) | x <- l ]
+         where count a l = length [ x | x <- l, x == a]
+
+dist :: (Eq a, Fractional b) => [a] -> [(a, b)]
+dist l = [ (x, (fromIntegral n) / (fromIntegral t)) | (x,n) <- hist l ] where t = length l
+
+histpair h1 h2 = both `fcomp` (split (tot h1 0)(tot h2 0)) where both = crflx (dom h1 `union` dom h2)
+
+-- miscellaneous
+
+discollect :: [(a, [b])] -> [(a, b)]
+discollect = (>>=lstr)
+
+presort f = map snd . sort . (map (split f id)) -- pre-sorting on f-preorder
+
+rpresort f = reverse . (presort f) -- the same in reverse ordering
+
+sdiff x y = set [ a | a <- x, not(elem a y) ]
+
+a |-> b = (a,b)
+
+(f `is` v) x = (f x) == v
+
+(f `belongs` v) x = (f x) `elem` v
+
+(v `can_be_found_in` f) x = v `elem` (f x)
+
+(f `isnot` v) x = (f x) /= v
+
+unpair(a,b)=[a,b]
+
+pair [a,b]=(a,b)
+
+a .><. b = [ (x,y) | x <- a, y <- b ]
+x .+. y = map Left x ++ map Right y
+-----------------------------------------------------------------------------
+proj k a = map (split k a)
+{-----------------------------------------------------------------------------
+-- Sample data
+
+data A = A1 | A2 | A3 | A4 | A5 deriving (Show,Eq,Ord,Enum)
+data B = B1 | B2 | B3 | B4 | B5 deriving (Show,Eq,Ord,Enum)
+
+tA = [A1 .. A5]
+tB = [B1 .. B5]
+
+idA = crflx tA
+idB = crflx tB
+-----------------------------------------------------------------------------}
+
+rcons(x,a) = x++[a]
+

cp2223t/Rose.hs

@@ -0,0 +1,53 @@
+
+{-# OPTIONS_GHC -XNPlusKPatterns #-}
+
+-- (c) MP-I (1998/9-2006/7) and CP (2005/6-2022/23)
+
+module Rose where
+
+import Cp
+import BTree
+import Exp
+import Data.List
+import Data.Monoid
+
+-- (1) Datatype definition -----------------------------------------------------
+
+data Rose a = Rose a [Rose a] deriving Show
+
+inRose = uncurry Rose
+
+outRose (Rose a x) = (a,x)
+
+-- (2) Ana + cata + hylo -------------------------------------------------------
+
+recRose g = baseRose id g
+
+cataRose g = g . (recRose (cataRose g)) . outRose
+
+anaRose g = inRose . (recRose (anaRose g) ) . g
+
+hyloRose h g = cataRose h . anaRose g
+
+baseRose f g = f >< map g
+
+-- (3) Map ---------------------------------------------------------------------
+
+instance Functor Rose
+         where fmap f = cataRose ( inRose . baseRose f id )
+
+-- (4) Examples ----------------------------------------------------------------
+
+-- count 
+
+count = cataRose (succ.sum.p2)
+
+sumRose = cataRose (add.(id><sum))
+
+mirrorRose = cataRose (inRose.(id><reverse))
+
+g =  cataBTree (either (const Nothing) (Just . inRose . (id><f))) where
+  f(Nothing,Nothing)=[]
+  f(Nothing,Just a)=[a]
+  f(Just a,Nothing)=[a]
+  f(Just a,Just b)=[a,b]

cp2223t/Show.hs

@@ -0,0 +1,16 @@
+module Show where
+
+showL :: Show a => Int -> a -> String
+showL n x = s++rep (n-length s) ' '
+            where s=show x
+
+showR :: Show a => Int -> a -> String
+showR n x = rep (n-length s) ' '++s
+            where s=show x
+
+--showP :: Float -> String
+--showP f =  showR 3 (round (f*100))++"%"
+
+rep :: Int -> a -> [a]
+rep n x = take n (repeat x)
+

cp2223t/St.hs

@@ -0,0 +1,96 @@
+
+-- (c) MP-I and CP (1998/99-2022/23)
+
+module St where
+
+import Cp
+import Control.Applicative
+
+------------------------------------------------------------------
+-- NB: This is a small, pointfree "summary" of Control.Monad.State
+------------------------------------------------------------------
+
+data St s a = St { st :: (s -> (a, s)) }
+
+inSt  = St
+outSt = st
+
+-- NB: "values" of this monad are actions rather than states.
+--     So this should be called the "action monad" and not the
+--     "state monad".
+--     (Unfortunately, it is to late to change terminology.)
+
+--------------------------------------------------------------------------
+instance Monad (St s) where
+         return       = St . (curry id)
+         (St x) >>= g = St   (uncurry(st . g) . x )
+{-- ie:
+         (St x) >>= g = St (\s -> let (a,s') = x s
+                                      St k   = g a
+                                  in k s')
+--}
+--------------------------------------------------------------------------
+instance Functor (St s) where
+         fmap f t = do { a <- t ; return (f a) }  -- as in every monad
+-- ie:   fmap f (St g) = St(\s -> let (a,s') = g s in (f a,s'))
+
+--------------------------------------------------------------------------
+-- action execution
+
+exec :: St s a -> s -> (a, s)
+exec (St g) s =  g s                      -- splits evalState and execState
+
+-- generic actions 
+
+get   :: St s s                           -- as in class MonadState
+get = St(split id id) 
+
+modify :: (s -> s) -> St s ()
+modify f = St(split (!) f)
+
+put :: s -> St s ()                       -- as in class MonadState
+put s = modify (const s)
+
+query :: (s -> a) -> St s a
+query f = St(split f id)
+
+trans :: (s -> s) -> (s -> a) -> St s a   -- a simple transation
+trans g f = do { modify g ; query f }
+
+-- actions with input
+
+meth :: ((a, s) -> (b, s)) -> a -> St s b
+meth f = St.(curry f)                     -- create "method" from function
+
+-- update state, then query 
+
+updfst :: (a -> s -> s) -> (a -> s -> b) -> a -> St s b
+updfst g f a = St (split (f a) id . (g a))
+
+-- updfst g f a = do { modify (g a) ; query (f a)}
+
+-- example (ATM credit)
+
+credit = updfst (+) (bal) 
+           where bal a s = "credited= "++show a ++ ", bal= "++ show s
+
+-- query state, then update
+
+qryfst :: (a -> s -> s) -> (a -> s -> b) -> a -> St s b
+qryfst g f a = St(split (f a) (g a))
+
+-- qryfst g f a = do { b <- query (f a); modify (g a) ; return b }
+
+-- example (pop)
+pop_action = qryfst (\_ -> tail) (\_ -> head)
+
+-- execute forever
+
+loop :: Monad m => m a -> m b
+loop x = do { x ; loop x }
+
+--------------------------------------------------------------------------
+instance Applicative (St s) where
+   (<*>) = aap
+   pure  = return
+--------------------------------------------------------------------------

cp2223t/Svg.hs

@@ -0,0 +1,580 @@
+{-# OPTIONS_GHC -XNPlusKPatterns #-}
+
+-- (c) Ensico & UM (2022)
+
+module Svg where
+
+import Data.Ratio
+import Data.Char
+import Data.List
+import System.Process
+import Cp
+
+--- Basic -----------
+
+open h = do { writeFile "_.html" h ; system ("open _.html") } 
+
+converse = map swap
+
+a .><. b = [ (x,y) | x <- a, y <- b ]
+
+a # b = zip a b
+
+unrstr = (id >< head) . unzip
+
+collapse = map unrstr . transpose
+
+match p l i = p `isPrefixOf` (drop i l)
+
+r2 = (/100) . fromIntegral . round .(100*)
+
+-- Generic "derivative" / "integral"
+
+gderiv :: a -> (a -> a -> c) -> [a] -> [c]
+gderiv z f s = ttl (zipWith f s (z:s))
+              where ttl [] = []
+                    ttl (a:t) = t
+
+ginteg :: (a -> b -> b) -> b -> [a] -> [b]
+ginteg f i s = i:aux i s
+      where aux i [] = []
+            aux i (h:t) = i':(aux i' t)
+                          where i'=f h i
+
+-- Repetitions
+
+-- repeat anything 
+
+rep x = map (const x) [0..]
+
+-- (9) Misc.
+
+cut :: Int -> Int -> [a] -> [a]
+cut n m = (take (m-n+1)) . drop (n-1)
+
+inds :: [b] -> [Int]
+inds = (map fst) . (zip [1..])
+
+elems :: (Ord a) => [a] -> [a]
+elems = sort . nub
+
+-- misc
+
+sing a = [a]
+dup a = [a,a]
+
+a != b = not(a == b)
+
+a |-> b = (a,b)
+
+supermap f [] = []
+supermap f (a:l) = a:(map f (supermap f l))
+
+show2 = show.show
+
+--- list of pairs to list
+
+lp2l :: [(b, b)] -> [b]
+lp2l = (concat . map f) where f(a,b)=[a,b]
+
+frac n m = n%m
+
+-- for combinator
+
+for b i 0 = i
+for b i (n+1) = b(for b i n)
+
+presort f = map snd . sort . (map (split f id)) -- pre-sorting on f-preorder
+
+apl :: [a -> b] -> [a] -> [b]
+apl f l = map ap (zip f l)
+
+--- HTML minimal API ("shallow embedding")
+
+tag t l x = "<"++t++" "++ps++">"++x++"</"++t++">"
+             where ps = unwords [concat[t,"=",v]| (t,v)<-l]
+
+tg t l = "<"++t++" "++ps++"/>"
+             where ps = unwords [concat[t,"=",v]| (t,v)<-l]
+
+htm = tag "html" []
+
+strong  = tag "strong" []
+
+tr  = tag "tr" []
+
+img fn = tag "img" [ "src" |-> (show fn) ] ""
+
+uli = ul . (>>= li) where
+    li  = tag "li" []
+    ul  = tag "ul" []
+
+htable = nest "table" [ "border" |-> "1" , "data-toggle" |-> "\"table\"" ]
+             (nest "tr" [] (tag "td" [ "align" |-> "center"]))
+                where nest t p f = (tag t p) . (>>=f)
+                
+pretty = (open . htm . htable) 
+
+--- remove diacritics where needed
+
+cl '\237'= 'i'
+cl '\243'= 'o'
+cl '\227'= 'a'
+cl '\231'= 'c'
+cl c     = c
+
+--- basic -----------
+
+mT :: Eq a => [(a, b)] -> a -> Maybe b
+mT = flip lookup
+
+pap :: Eq a => [(a, t)] -> a -> t
+pap m = unJust . (mT m) where unJust (Just a) = a -- partial inspector of simple relation A->B
+
+-- Abstract (point) level
+
+infix 5  .|
+infix 4  .+
+infix 4  .-
+
+a .| (x,y) = (a*x,a*y)
+
+trans p = map (p .+)
+
+(x,y) .+ (x',y') = (x+x',y+y')
+
+(x,y) .- (x',y') = (x-x',y-y')
+
+a .* (x,y) = (a*x,a*y)
+
+amplia r = map (r .*)
+
+amplia' s p = trans (p .- s .* p) . amplia s
+
+reduz r = amplia (1/r)
+
+-- SVG -----------------------------------
+
+s = (200*)
+
+sstep (x,y) = (200*x,-200*y)
+
+scl p = sstep p .+ (-1400,1400)
+
+shp (x,y) = show x ++ "," ++ show y  -- format for coord list
+
+shpts xs = intercalate " " (map (shp.scl) xs) -- with offset
+
+shpts' xs = intercalate " " (map (shp.sstep) xs)
+
+rscale p = let (x,y) = scl p in (round x,round y)
+
+-- paths
+
+path d = tg "path" [ "d" |-> show d ]
+
+slice r (p1,p2) = path $ " M " ++ shp (scl p1) ++ arc (s r) (scl p2) ++ " L " ++ shp (scl p3) where
+  arc r p = " A " ++ shp (r,r) ++ " 0 0 0 " ++ shp p ++ " "
+  p3 = (0,0)
+
+-- polylines
+
+poly xs = tg "polyline" ["points" |-> show (shpts xs), "style"  |-> show "fill:none;stroke-width:5" ]
+
+poly' xs = tg "polyline" ["points" |-> show (shpts xs), "style"  |-> show "fill:none;stroke-width:8" ]  -- thicker
+
+seg p q = poly [p,q]
+
+-- polygons 
+
+polyg xs = tg "polygon" ["points" |-> show  (shpts xs)] 
+
+tri = polyg
+
+squ = polyg
+
+rect x y = polyg [(0,0),(x,0),(x,y),(0,y),(0,0)]
+
+sqr x = rect x x
+
+cir (x,y) r = tg "circle" [
+   "cx" |-> show2 x',"cy" |-> show2 y', "r" |-> show2 r',
+   "stroke" |-> show "black", "stroke-width" |-> show2 3 ] where
+      (x',y') = scl (x,y)
+      (r',_) = sstep (r,0)
+
+elp (x,y) (rx,ry) = tg "ellipse" [
+   "cx" |-> show2 x',"cy" |-> show2 y', "rx" |-> show2 rx', "ry" |-> show2 ry', 
+   "stroke" |-> show "black", "stroke-width" |-> show2 3 ] where
+      (x',y') = scl (x,y)
+      (rx',_) = sstep (rx,0)
+      (ry',_) = sstep (ry,0)
+
+-- points
+
+point p = let (x,y) = scl p in tg "circle" ["cx" |-> show2 x,"cy" |-> show2 y, "r" |-> show2 15]
+point' p = tag "g" ["font-size" |-> show2 60] (point p ++ black(stext (scl (p.+(-0.5,0.2))) (shows p))) where
+   shows(x,y) = "("++ s x ++ "," ++ s y ++ ")"
+   s x = if abs(x-fromIntegral (round x)) < 0.001 then show (round x) else show (r2 x)
+
+points' = (>>= point')
+points = (>>= point)
+
+-- rotation
+
+polar (x,y) = (atan2 y x,sqrt(x^2+y^2))
+
+cart (a,r) = (cos a * r, sin a * r) 
+
+rad r = r*pi/180
+
+rot r p = (x',y') where 
+   (a,c) = polar p
+   a' = a + rad r
+   y' = c*sin a'
+   x' = c*cos a'
+
+rotate r p a = tag "g" [ "transform" |-> show ("rotate(" ++ t ++ ")") ] a where
+   (x,y) = scl p
+   t = unwords [show r, show x, show y]
+
+-- translation
+
+translate p = tag "g" [ "transform" |-> show ("translate"++p') ] where p' = show(sstep p)
+
+put = translate
+
+-- (static) scaling
+
+scale k p = translate (p' .- k .* p') . 
+            tag "g" ["transform" |-> show("scale(" ++ show k ++ ")") ]
+                where p' = p .- (7,7)
+
+-- colored regions
+
+color c = tag "g" ["fill" |-> show c, "stroke" |-> show c] 
+white = color "white"
+black = color "black"
+gray = color "gray"
+yellow = color "yellow"
+green = color "green"
+red = color "red"
+blue = color "blue"
+orange = color "orange"
+magenta = color "magenta"  
+brown = color "brown" 
+
+-- grouping
+
+grp = tag "g" [] . concat
+
+-- vectors, lines and grid
+
+vec p q = 
+   let (x1,y1) = scl p
+       (x2,y2) = scl q
+   in tg "line" [
+         "x1" |-> show2 x1, "y1" |-> show2 y1, "x2" |-> show2 x2, "y2" |-> show2 y2,
+         "stroke-width" |-> show2 8, "marker-end" |-> show "url(#arrowhead)" ]
+         
+-- line (x1,y1)(x2,y2) = tag "line" ["x1" |-> x1, "y1" |-> y1, "x2" |-> x2, "y2" |-> y2]
+
+lin (x1,y1) (x2,y2) = tg "line" ["x1" |-> show2 x1, "y1" |-> show2 y1, "x2" |-> show2 x2, "y2" |-> show2 y2]
+
+
+grid n = f n ++ map (sym><sym) (f n) where 
+   f n = [((n,-1500),(n,1500))]
+   sym (x,y) = (y,x)
+
+-- definitions
+
+dfs = tag "defs" [] .
+      tag "marker" [ "id" |-> show "arrowhead",
+                     "markerWidth" |-> show2 10,
+                     "markerHeight"|-> show2 8,
+                     "refX" |-> show2 9,
+                     "refY" |-> show2 4,
+                     "orient" |-> show "auto"] $
+            tg "polygon" [ "fill" |-> show "gray", "points" |-> show "0,0 10,4 0,8" ]
+
+-- the grid and X-Y plane
+
+planoxy p x = wrap (dfs ++ grd ++ coords ++ axes ++  concat x)
+  where
+    wrap = tag "svg" [
+               "width"   |-> show2 500,
+               "height"  |-> show2 500,
+               "viewBox" |-> show "-1500 -1500 3000 3000",
+               "version" |-> show "1.1",
+               "xmlns"   |-> show "http://www.w3.org/2000/svg"
+               ]
+    trans p = tag "g" [ "transform" |-> show ("translate"++p') ] where p' = show p
+    xarrowhead = polyg [(0,-0.1),(0.3,0),(0,0.1)]
+    yarrowhead = polyg [(0.1,0),(0,0.3),(-0.1,0)]
+    base = let a =[0,40..1500] in a ++ map ((-1)*) a
+    xs = [0..13] >>= coordx
+    ys = [1..13] >>= coordy
+    coordx i = stext (scl (i,-0.4)) (show i)
+    coordy i = stext (scl (-0.4,i)) (show i)
+    coordy' i = stext (scl (-0.55,i)) (show i)
+    lx i = lin (i,-1400) (i,1400) ++ lin (-1400,i) (1400,i)
+    ly i = lin (-1400,i) (1400,i)
+    --- axes -------------------------------------------------
+    axes = blacklines [((-1400.0,1480.0),(-1400.0,-1480.0)),((-1480.0,1400.0),(1480.0,1400.0))] ++
+           trans (sstep (14.2,0)) xarrowhead ++
+           trans (sstep (0,14.2)) yarrowhead ++
+           tag "g" ["font-style" |-> show "italic", "font-size" |-> show2 100] (gray (
+              stext (scl (14,-0.5)) "x" ++
+              stext (scl (-0.5,14)) "y"
+              ))
+    blacklines ls = tag "g" ["stroke" |-> show "black", "stroke-width" |-> show2 5.0] (ls >>= uncurry lin)
+    --- grid -------------------------------------------------
+    grd = graylines (base >>= grid) ++ 
+           tag "g" ["stroke" |-> show "gray", "stroke-width" |-> show2 3] ([-1400,-1200..1400] >>= lx)
+    graylines ls = tag "g" ["stroke" |-> show "gray", "stroke-width" |-> show2 p] (ls >>= uncurry lin)
+    --- coords -----------------------------------------------
+    coords = tag "g" ["font-size" |-> show2 80] (xs ++ ys)
+    ----------------------------------------------------------
+   
+-- Show in X-Y Cartesian plane
+
+picd = open . htm . planoxy 0.9
+
+picd' = open  . htm . planoxy 0  -- gray intensity = 0
+
+picd'' = open . htm . wrap . concat
+
+wrap = tag "svg" [
+               "width"   |-> show2 500,
+               "height"  |-> show2 500,
+               "viewBox" |-> show "-1500 -1500 3000 3000",
+               "version" |-> show "1.1",
+               "xmlns"   |-> show "http://www.w3.org/2000/svg"
+               ]
+
+-- HELPER: para mostrar polygs (apenas):
+
+polyd t =  picd [ green(polyg t) ++ points'' t ]
+
+points'' ps = blue(points' ps) ++  red(points projs)
+         where projs  = map f ps ++ map (swap.f.swap) ps
+               f(x,_) = (x,0)
+
+--- Vectors
+
+pnt p = red (vec (0,0) p)
+
+pnts = grp . map pnt
+
+--- Plotting 
+
+plt f = map (pnt f . (/10)) . take width $ [0..] where
+   pnt f x = (x, f x)
+   width = 142
+
+plot = poly . plt
+
+plot' = poly' . plt
+
+-- Images
+
+image fn d = tg "image" [ "href" |-> show fn, "height" |-> show2 h, "width" |-> show2 w ]
+   where (w,h) = (s >< s) d
+
+-- Animations
+
+anima t f x = animamea x p (show t++"s") where p = take t . map f $ [0..]
+
+anima' t d (i,n,v) x = animamea x p (show d++"s") where 
+   p = map v (take m y) -- v is the "view" extracting (x,y) 
+   y = ana n i
+   ana n s = s : ana n (n s)
+   m = sample t d
+
+anims d f t o = translate (-7,-7) x where
+   x = tag "g" [] (o' ++ st)
+   f' = unwords [show f,show f]
+   t' = unwords [show t,show t]
+   o' = translate (7,7) o
+   st = animT "0s" (show d++"s") "scale" f' t' "0"
+ 
+animf t f a = animamea a (plt f) t  --- animation over function graph
+
+animamea o p t = tag "g" [] (o ++ (animM (shpath p) t "0"))
+
+shpath p = "M " ++ shpts' p ++ " " -- no way back, cf shpath p = "M " ++ shpts' p ++ " Z"
+
+animM p d c = tg "animateMotion" [
+   "path" |-> show p, 
+   "dur" |-> show d, 
+   "repeatCount" |-> show c
+   ] 
+
+sample :: Float -> Float -> Int
+sample t d = round(d/t)
+
+-- animd o p t = picd [ animamea o p t ]
+-- path i n = i : map n (path i n)
+
+-- Reflections
+
+refl q p = q .+ (q .- p)
+
+hrefl y0 p = [ (x,2*y0-y) | (x,y) <- p ]
+ 
+vrefl x0 p = [ (2*x0-x,y) | (x,y) <- p ]
+
+
+-- Rotations
+
+animT b d k f t c = tg "animateTransform" [
+   "attributeName" |-> show "transform",
+   "begin" |-> show b, 
+   "dur" |-> show d, 
+   "type" |-> show k, 
+   "from" |-> show f, 
+   "to" |-> show t, 
+   "repeatCount" |-> show c
+   ]
+   
+animr d f t o = animarot o d f t 
+
+animarot o d (f,p) (t,q) = 
+   tag "g" [] (o ++ animT "0s" (show d ++ "s") "rotate" fs ts "indefinite") where
+      fs = unwords [show f, show x, show y]
+      ts = unwords [show t, show x', show y']
+      (x,y) = scl p
+      (x',y') = scl q
+
+-- Text
+
+txt p = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "font-size" |-> show2 100 ] where (x,y) = scl p
+
+italic = tag "g" [ "font-style" |-> "italic" ]
+
+anchor k = tag "g" [ "text-anchor" |-> show k ] -- k = "end"
+
+-- Pie diagrams
+
+mkp r ps = a # rtl a where         -- polar coordinates
+    a = aux r ps
+    rtl [] = []
+    rtl x = tail x ++ [ head x ]
+    aux r = map (cart . curry swap r . (2*pi*)) . ginteg (+) 0
+
+dist x = map (/t) x where t = sum x -- distribution
+
+perc x = map (/t) x where t = maximum x -- percentage 
+
+dom = map fst
+rng = map snd
+
+pied db = picd' (pie (map snd db) ++ map f a) where
+         a = colours # [1,2..] # map sh (dom db # dist(rng db))
+         sh (a,n) = a ++ ": " ++ sprec n
+         f((c,y),s) = ap(c, txt (1,y) s)
+
+pie d = y where
+  r = 4 -- radius
+  y = map (translate (9,9) . ap) (colours # x)
+  x = map (slice r) . mkp r . dist $ d
+
+colours = [blue,green,yellow,orange,red,magenta,gray,brown,black] ++ colours 
+
+sprec n = show (round(n*100)) ++ " %"
+
+-- histograms in svg
+
+histd db = picd'' $ (db' >>= bar) where 
+   span db = 13 / fromIntegral(length db)
+   wth db  =  9 / fromIntegral(length db)
+   ylabels = (fromIntegral . maximum . map length . dom) db `min` 5
+   small p = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "font-size" |-> show2 80 ] where (x,y) = scl p
+   r = map fromIntegral (rng db)
+   db'=sort $ db # (perc r # [ span db * fromIntegral i | i <- [1..]] )
+   bar ((s,v),(p,x)) =
+          [ (brown . translate (x-w/2,y0)) (rect w y),
+            (blue  . rotate 90 (x,y0-0.5) . txt (x,y0-0.5)) s,
+            (gray  . anchor "middle" . small (x,y0+y + 0.2 ) . show) v
+          ] where y  = p*(12-y0)
+                  w  = wth db
+                  y0 = ylabels
+
+stext (x,y) = tag "text" [ "x" |-> show2 x, "y" |-> show2 y ]  -- simple text
+
+
+text x y t = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "dy" |-> show "0.35em", "font-size" |-> show2 5] t
+
+title t s = tag "title" ["id" |-> show "title"] t ++ s
+
+bar s (y,(a,n)) = tag "g" [ "class" |-> show "bar", "transform" |-> show ("translate(0,"++show y++")") ]
+      $ aux (a,n) where
+        s' n = s (fromIntegral n)
+        aux (t,x) = rect (s' x) ++
+                    tag "text" [ "x" |-> show2 (s' x+5),
+                                 "y" |-> show2 7.5,
+                                 "dy" |-> show "0.30em"] (t ++ " [ " ++ show (x) ++ " ]")
+        rect x  = tag "rect" [ "width" |-> show2 x, "height" |-> show2 10, "style" |-> show "fill:rgb(185,181,180);stroke-width:1;stroke:rgb(256,256,256)"] ""
+
+fdiv :: Int -> Int -> Float
+fdiv n m = fromIntegral n / fromIntegral m
+
+svg' x y = tag "svg" 
+     [ "version" |-> show "1.1",
+       "xmlns" |-> show "http://www.w3.org/2000/svg",
+       "xmlns:xlink" |-> show "http://www.w3.org/1999/xlink",
+       "class" |-> show "chart",
+       "width" |-> show2 1000,
+       "height" |-> show2 (y * 24),
+       "aria-labelledby" |-> show "title",
+       "role" |-> show "img"
+     ]
+
+------ SETS AND FUNCTIONS
+
+src (x,y) t = grp [
+       red (point (x,y)),
+       blue (end (txt (x-0.29,y-0.15) t)) 
+       ] where end = anchor "end"
+       
+dst (x,y) t = grp [
+       red (point (x,y)),
+       blue (txt (x+0.29,y-0.15) t)
+       ]
+       
+ffdAux ff = (map (g><id) a,map (h><id) (converse b),[(g i,h(f i)) | i <- map fst a ]) where
+  a = zip [1..] l
+  b = zip r [1..]
+  f = pap b . pap ff . pap a
+  (l,r) = (nub >< nub) . unzip $ ff
+  g y = (5,y)
+  h y = (9,y)
+
+bold = tag "g" [ "font-weight" |-> show "bold" ]
+  
+container n c x a = grp [
+   c (elp (x, (m+1)/2) (2,m')), 
+   (red . center . bold) (txt (x,m + 2) n)
+   ] where m = fromIntegral (length a)
+           m' = 0.6 * m
+           center = anchor "middle"
+
+-- diagrams of functions
+
+fund f = ffd (graph f [minBound .. maxBound])
+
+ffd ff na nb = picd'' . singl . (translate (0,3)) . scale 1 (0,0) . grp $ 
+     [ container na yellow 4 a,
+       container nb orange 10 b, 
+       gray (p >>= uncurry vec), 
+       a >>= uncurry src,
+       b >>= uncurry dst
+     ] where (a,b,p) = ffdAux ff
+
+graph f = map (split show (show.f))
+
+graph' f = map (split show f) 
+
+mhd f = histd (graph' f [minBound .. maxBound]) -- measure histograms
+
+---

cp2223t/cp2223t.bib

@@ -0,0 +1,84 @@
+
+@String{pub-SUCSLI              = "Stanford University Center for the
+                                  Study of Language and Information"}
+@String{pub-SUCSLI:adr          = "Stanford, CA, USA"}
+
+@book{KR78,
+    author =	"B.W. Kernighan and D.M. Richtie",
+    title=	{The {C} Programming Language},
+    publisher=	{Prentice Hall, Englewood Cliffs, N.J.},
+    year={1978}
+}
+@book{Hu00,
+   KEY = "Hu00",
+   AUTHOR = "P. Hudak",
+   TITLE = {\htmladdnormallink{The Haskell School of Expression - Learning Functional Programming Through Multimedia}{http://www.haskell.org/soe/}},
+   PUBLISHER = "Cambridge University Press",
+   EDITION = "1st",
+   YEAR = "2000",
+   NOTE = "ISBN 0-521-64408-9"
+}
+@article{EK06,
+ longauthor = {Erwig, Martin and Kollmansberger, Steve},
+ author = {Erwig, M. and Kollmansberger, S.},
+ title = {FUNCTIONAL PEARLS: Probabilistic functional programming in {Haskell}},
+ journal = {J. Funct. Program.},
+ volume = {16},
+ issue = {1},
+ month = {January},
+ year = {2006},
+ noissn = {0956-7968},
+ pages = {21--34},
+ numpages = {14},
+ nourl = {http://dl.acm.org/citation.cfm?id=1114008.1114013},
+ nodoi = {10.1017/S0956796805005721},
+ acmid = {1114013},
+ publisher = {Cambridge University Press},
+ address = {New York, NY, USA},
+}
+@Book{Kn92,
+  author =       "D.E. Knuth",
+  longauthor =       "Donald E. Knuth",
+  title =        "Literate Programming",
+  publisher =    pub-SUCSLI,
+  address =      pub-SUCSLI:adr,
+  pages =        "xv + 368",
+  year =         "1992",
+  ISBN =         "0-937073-80-6 (paper), 0-937073-81-4 (cloth)",
+  ISBN-13 =      "978-0-937073-80-3 (paper), 978-0-937073-81-0 (cloth)",
+  LCCN =         "QA76.6.K644",
+  bibdate =      "Sun Jul 10 01:09:29 1994",
+  price =        "US\$24.95",
+  series =       "CSLI Lecture Notes Number 27"
+}
+
+@book{Kn86
+  , author = {D.E. Knuth}
+  , title = {The \TeX book}
+  , publisher = {Addison-Wesley Publishing Company}
+  , edition = {7th}
+  , year = {1986}
+}
+
+@book{GRM97
+  , title     = {The LaTeX Graphics Companion}
+  , author    = {Michel Goossens and Sebastian Rahtz and Frank Mittelbach}
+  , publisher = {Addison-Wesley}
+  , year      = {1997}
+  , note      = {ISBN 0-201-85469-4}
+}
+
+@misc{Ol18
+, author    = {J.N. Oliveira}
+, title     = {\href{https://www.di.uminho.pt/~jno/ps/pdbc.pdf}{Program Design by Calculation}}
+, note = {Textbook in preparation, 310 pages. Informatics Department, University of Minho. Current version: Sept. 2022}
+, year = {2022}
+}
+
+@misc{Se19
+, author = {SelfKey}
+, year = {2015}
+, title = {What is a {Merkle} Tree and How Does it Affect Blockchain Technology?}
+, note = {Blog:\\ \url{https://selfkey.org/what-is-a-merkle-tree-and-how-does-it-affect-blockchain-technology/}. Last read: \today.}
+}
+

cp2223t/cp2223t.idx

@@ -0,0 +1,85 @@
+\indexentry{U.Minho!Departamento de Inform\IeC {\'a}tica|hyperpage}{1}
+\indexentry{C\IeC {\'a}lculo de Programas|hyperpage}{1}
+\indexentry{Haskell|hyperpage}{1}
+\indexentry{Haskell|hyperpage}{1}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {for}|hyperpage}{2}
+\indexentry{U.Minho!Departamento de Inform\IeC {\'a}tica|hyperpage}{2}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Exp.hs|hyperpage}{2}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Exp.hs|hyperpage}{2}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Exp.hs|hyperpage}{2}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Exp.hs|hyperpage}{3}
+\indexentry{Fractal!Tapete de Sierpinski|hyperpage}{3}
+\indexentry{Fractal|hyperpage}{3}
+\indexentry{C\IeC {\'a}lculo de Programas|hyperpage}{3}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Rose.hs|hyperpage}{4}
+\indexentry{Functor|hyperpage}{5}
+\indexentry{Functor|hyperpage}{5}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!LTree.hs|hyperpage}{6}
+\indexentry{Combinador ``pointfree''!\emph  {either}|hyperpage}{7}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!LTree.hs|hyperpage}{7}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{7}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{8}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!LTree.hs|hyperpage}{8}
+\indexentry{Functor|hyperpage}{8}
+\indexentry{Functor|hyperpage}{8}
+\indexentry{Functor|hyperpage}{8}
+\indexentry{Functor|hyperpage}{9}
+\indexentry{Combinador ``pointfree''!\emph  {either}|hyperpage}{9}
+\indexentry{Programa\IeC {\c c}\IeC {\~a}o!liter\IeC {\'a}ria|hyperpage}{9}
+\indexentry{Programa\IeC {\c c}\IeC {\~a}o!liter\IeC {\'a}ria|hyperpage}{9}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico|hyperpage}{9}
+\indexentry{Haskell!Literate Haskell|hyperpage}{9}
+\indexentry{\LaTeX  !\texttt  {lhs2TeX}|hyperpage}{10}
+\indexentry{\LaTeX  |hyperpage}{10}
+\indexentry{Haskell|hyperpage}{10}
+\indexentry{Haskell!interpretador!GHCi|hyperpage}{10}
+\indexentry{C\IeC {\'a}lculo de Programas|hyperpage}{10}
+\indexentry{\LaTeX  !\texttt  {bibtex}|hyperpage}{10}
+\indexentry{\LaTeX  !\texttt  {makeindex}|hyperpage}{10}
+\indexentry{Haskell|hyperpage}{10}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _1$|hyperpage}{10}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{10}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _1$|hyperpage}{10}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{10}
+\indexentry{N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$)|hyperpage}{11}
+\indexentry{N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$)|hyperpage}{11}
+\indexentry{N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$)|hyperpage}{11}
+\indexentry{Programa\IeC {\c c}\IeC {\~a}o!din\IeC {\^a}mica|hyperpage}{11}
+\indexentry{N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$)|hyperpage}{11}
+\indexentry{Functor|hyperpage}{11}
+\indexentry{C\IeC {\'a}lculo de Programas|hyperpage}{11}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _1$|hyperpage}{11}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {for}|hyperpage}{11}
+\indexentry{N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$)|hyperpage}{11}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _1$|hyperpage}{11}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {for}|hyperpage}{11}
+\indexentry{Haskell!Biblioteca!Probability|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Haskell!interpretador!GHCi|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Functor|hyperpage}{12}
+\indexentry{Haskell!Biblioteca!Probability|hyperpage}{12}
+\indexentry{Haskell!Biblioteca!PFP|hyperpage}{12}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{13}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{13}
+\indexentry{C\IeC {\'a}lculo de Programas!Material Pedag\IeC {\'o}gico!Exp.hs|hyperpage}{13}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {length}|hyperpage}{13}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {length}|hyperpage}{13}
+\indexentry{SVG (Scalable Vector Graphics)|hyperpage}{13}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{14}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{15}
+\indexentry{Functor|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _1$|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!\emph  {map}|hyperpage}{15}
+\indexentry{Fun\IeC {\c c}\IeC {\~a}o!$\pi _2$|hyperpage}{15}
+\indexentry{Functor|hyperpage}{16}
+\indexentry{Functor|hyperpage}{16}

cp2223t/cp2223t.ilg

@@ -0,0 +1,6 @@
+This is makeindex, version 2.15 [TeX Live 2017] (kpathsea + Thai support).
+Scanning input file cp2223t.idx....done (85 entries accepted, 0 rejected).
+Sorting entries....done (547 comparisons).
+Generating output file cp2223t.ind....done (62 lines written, 0 warnings).
+Output written in cp2223t.ind.
+Transcript written in cp2223t.ilg.

cp2223t/cp2223t.ind

@@ -0,0 +1,62 @@
+\begin{theindex}
+
+  \item \LaTeX  , \hyperpage{10}
+    \subitem \texttt  {bibtex}, \hyperpage{10}
+    \subitem \texttt  {lhs2TeX}, \hyperpage{10}
+    \subitem \texttt  {makeindex}, \hyperpage{10}
+
+  \indexspace
+
+  \item C\IeC {\'a}lculo de Programas, \hyperpage{1}, \hyperpage{3}, 
+		\hyperpage{10, 11}
+    \subitem Material Pedag\IeC {\'o}gico, \hyperpage{9}
+      \subsubitem Exp.hs, \hyperpage{2, 3}, \hyperpage{13}
+      \subsubitem LTree.hs, \hyperpage{6--8}
+      \subsubitem Rose.hs, \hyperpage{4}
+  \item Combinador ``pointfree''
+    \subitem \emph  {either}, \hyperpage{7}, \hyperpage{9}
+
+  \indexspace
+
+  \item Fractal, \hyperpage{3}
+    \subitem Tapete de Sierpinski, \hyperpage{3}
+  \item Fun\IeC {\c c}\IeC {\~a}o
+    \subitem $\pi _1$, \hyperpage{10, 11}, \hyperpage{15}
+    \subitem $\pi _2$, \hyperpage{10}, \hyperpage{15}
+    \subitem \emph  {for}, \hyperpage{2}, \hyperpage{11}
+    \subitem \emph  {length}, \hyperpage{13}
+    \subitem \emph  {map}, \hyperpage{7, 8}, \hyperpage{13--15}
+  \item Functor, \hyperpage{5}, \hyperpage{8, 9}, \hyperpage{11, 12}, 
+		\hyperpage{15, 16}
+
+  \indexspace
+
+  \item Haskell, \hyperpage{1}, \hyperpage{10}
+    \subitem Biblioteca
+      \subsubitem PFP, \hyperpage{12}
+      \subsubitem Probability, \hyperpage{12}
+    \subitem interpretador
+      \subsubitem GHCi, \hyperpage{10}, \hyperpage{12}
+    \subitem Literate Haskell, \hyperpage{9}
+
+  \indexspace
+
+  \item N\IeC {\'u}meros naturais ($I\tmspace  -\thinmuskip {.1667em}\tmspace  -\thinmuskip {.1667em}N$), 
+		\hyperpage{11}
+
+  \indexspace
+
+  \item Programa\IeC {\c c}\IeC {\~a}o
+    \subitem din\IeC {\^a}mica, \hyperpage{11}
+    \subitem liter\IeC {\'a}ria, \hyperpage{9}
+
+  \indexspace
+
+  \item SVG (Scalable Vector Graphics), \hyperpage{13}
+
+  \indexspace
+
+  \item U.Minho
+    \subitem Departamento de Inform\IeC {\'a}tica, \hyperpage{1, 2}
+
+\end{theindex}

cp2223t/cp2223t.sty

@@ -0,0 +1,242 @@
+%================= Standard packages ==========================================%
+\usepackage{fleqn}
+\usepackage[portuguese]{babel}
+\usepackage[utf8]{inputenc}
+\usepackage{mathptmx} % math font
+\usepackage{tabularx}
+%----------------- testing ----------------------------------------------------%
+\newtheorem{teste}{\underline{Teste unitário}}%
+\newtheorem{propriedade}{\relax{Propriedade [\href{https://hackage.haskell.org/package/QuickCheck}{QuickCheck}]}}%
+%----------------- verbatim ---------------------------------------------------%
+\usepackage{fancyvrb}
+%----------------- Using xy ---------------------------------------------------%
+\usepackage[all]{xy}
+\def\larrow#1#2#3{\xymatrix{ #3 & #1 \ar[l]_-{#2} }}
+\def\rarrow#1#2#3{\xymatrix{ #1 \ar[r]^-{#2} & #3 }}
+\def\u{u} % unidade de um mónade
+\def\fun#1{{\sf #1}\index{Functor}}
+%----------------- Colors -----------------------------------------------------%
+\usepackage{color}
+\usepackage[dvipsnames]{xcolor}
+\definecolor{url}{HTML}{0F80FF}
+\hypersetup{
+    linkcolor=url,
+    citecolor=url,
+    urlcolor=url
+}
+
+\definecolor{codegreen}{rgb}{0,0.6,0}
+\definecolor{codegray}{rgb}{0.5,0.5,0.5}
+\definecolor{codepurple}{rgb}{0.58,0,0.82}
+\definecolor{backcolour}{HTML}{fcf4e8}
+
+%----------------- Listings ---------------------------------------------------%
+\usepackage{listings}
+\lstset{
+    backgroundcolor=\color{backcolour},   
+    commentstyle=\color{codegreen},
+    keywordstyle=\color{magenta},
+    numberstyle=\tiny\color{codegray},
+    stringstyle=\color{codepurple},
+    basicstyle=\ttfamily\footnotesize,
+    breakatwhitespace=false,         
+    breaklines=true,                 
+    captionpos=b,                    
+    keepspaces=true,                 
+    numbers=left,                    
+    numbersep=5pt,                  
+    showspaces=false,                
+    showstringspaces=false,
+    showtabs=false,                  
+    tabsize=2
+}
+%----------------- tikz -------------------------------------------------------%
+\usepackage{tikz}
+\usepackage{tikz-qtree}
+\usetikzlibrary{trees}
+%----------------- anamorphism's brackets -------------------------------------%
+\newcommand{\lanabracket}{\mathopen{[\!\!\!\:(}}
+\newcommand{\ranabracket}{\mathopen{)\!\!\!\:]}}
+
+%---------------- boxes -------------------------------------------------------%
+\usepackage[many]{tcolorbox} 
+\tcbset{
+    sharp corners,
+    colback = white,
+    before skip = 0.5cm,
+    after skip = 0.5cm,
+    breakable
+}
+\newtcolorbox{alert}{
+    colback = Dandelion!7.5,
+    enhanced,
+    colframe = Dandelion!7.5,
+    borderline west = {4pt}{0pt}{Dandelion!50},
+    breakable
+}
+\newtcolorbox{bquote}{
+    colback = url!5,
+    enhanced,
+    colframe = url!5,
+    borderline west = {4pt}{0pt}{RoyalBlue!50},
+    breakable
+}
+\tcbset{
+    sharp corners,
+    colback = white,
+    before skip = 0.5cm,
+    after skip = 0.5cm,
+    boxsep=0mm,
+    breakable
+}
+\newtcolorbox{normalbox}{
+    colback = white,
+    enhanced,
+    colframe = black,
+    boxrule = 0.5pt,
+    breakable
+}
+
+%----------------- Using makeidx ----------------------------------------------%
+\usepackage{makeidx}
+\def\tree#1{\href{https://en.wikipedia.org/wiki/Tree_(data_structure)}{#1}\index{Árvore (Estrutura de Dados)}}
+\def\dijkstra#1{\href{https://en.wikipedia.org/wiki/Edsger_W._Dijkstra}{#1}\index{Edsger W. Dijkstra}}
+\def\shuntingYard#1{\href{https://en.wikipedia.org/wiki/Shunting_yard_algorithm}{#1}\index{Shunting Yard}}
+\def\sierpCarpet#1{\href{https://en.wikipedia.org/wiki/Sierpinski_carpet}{#1}\index{Fractal!Tapete de Sierpinski}}
+\def\sierpTriangle#1{\href{http://en.wikipedia.org/wiki/Sierpinski_triangle}{#1}\index{Fractal!Tri\^angulo de Sierpinski}}
+\def\fractal{\href{http://pt.wikipedia.org/wiki/Fractal}{fractal}\index{Fractal}}
+\def\svg{\href{https://svgwg.org/svg2-draft/}{SVG}\index{SVG (Scalable Vector Graphics)}}
+\def\xml{\href{https://en.wikipedia.org/wiki/XML}{XML}\index{XML (Extensible Markup Language)}}
+\def\DSL{\href{https://www.researchgate.net/publication/254462947_Experience_report_A_do-it-yourself_high-assurance_compiler}{DSL}\index{DSL (linguaguem específica para domínio)}}
+\def\DL{\href{https://roberttlange.github.io/posts/2019/08/blog-post-6/}{Deep Learning}\index{Deep Learning)}}
+\def\Fsharp{\href{https://fsharp.org}{F\#}\index{F\#}}
+\def\catalan#1{\href{https://en.wikipedia.org/wiki/Catalan_number}{#1}\index{Números de Catalan}}
+\def\bezier#1{\href{https://en.wikipedia.org/wiki/B\%C3\%A9zier_curve}{#1}\index{Curvas de Bézier}}
+\def\Nat{\href{https://haslab.github.io/CP/Material/Nat.hs}{Nat}\index{Cálculo de Programas!Material Pedagógico!Nat.hs}}
+\def\Cp{\href{https://haslab.github.io/CP/Material/Cp.hs}{Cp}\index{Cálculo de Programas!Material Pedagógico!Cp.hs}}
+%-------
+\def\random#1{\href{https://hackage.haskell.org/package/random-1.1/docs/System-Random.html}{#1}\index{Haskell!Monad!Random}}
+\def\truchet#1{\href{https://en.wikipedia.org/wiki/Truchet_tiles}{#1}\index{Mosaico de Truchet}}
+\def\BTree{\href{https://haslab.github.io/CP/Material/BTree.hs}{BTree}\index{Cálculo de Programas!Material Pedagógico!BTree.hs}}
+\def\Bibtex{\href{http://www.bibtex.org/}{Bib\TeX}\index{\LaTeX!\texttt{bibtex}}}
+\def\Exp{\href{https://haslab.github.io/CP/Material/Exp.hs}{Exp}\index{Cálculo de Programas!Material Pedagógico!Exp.hs}}
+\def\Rose{\href{https://haslab.github.io/CP/2223/Material/Rose.hs}{Rose Tree}\index{Cálculo de Programas!Material Pedagógico!Rose.hs}}
+\def\GHCi{\ghci{GHCi}}
+\def\IO{IO\index{Mónade!{IO}}}
+\def\Dist{Dist\index{Mónade!{Dist}}}
+\def\listM#1{#1\index{Mónade!Listas}}
+\def\Html{\textsc{Html}\index{HTML}}
+\def\LTree{\href{https://haslab.github.io/CP/Material/LTree.hs}{\textit{LTree}}\index{Cálculo de Programas!Material Pedagógico!LTree.hs}}
+\def\FTree{\href{https://haslab.github.io/CP/Material/FTree.hs}{\textit{FTree}}\index{Cálculo de Programas!Material Pedagógico!FTree.hs}}
+\def\mTree#1{\href{https://en.wikipedia.org/wiki/Merkle_tree}{#1}\index{Merkle tree}}
+\def\MerkleTree{\mTree{Merkle tree}}
+\def\Latex{\href{http://www.tug.org/index.html}{\LaTeX}\index{\LaTeX}}
+\def\LhsToTeX{\lhstotex{lhs2tex}}
+\def\List{\href{http://wiki.di.uminho.pt/twiki/pub/Education/CP/MaterialPedagogico/List.hs}{List}\index{Cálculo de Programas!Material Pedagógico!List.hs}}
+\def\Makeindex{\href{https://www.ctan.org/pkg/makeindex}{\texttt{makeindex}}\index{\LaTeX!\texttt{makeindex}}}
+\def\MaterialPedagogico{\material{material pedagógico}}
+\def\blockchain{\href{https://pt.wikipedia.org/wiki/Blockchain}{blockchain}\index{Blockchain}}
+\def\PFP{\href{http://web.engr.oregonstate.edu/~erwig/pfp}{PHP}\index{Haskell!Biblioteca!PFP}}
+\def\Probability{\href{http://wiki.di.uminho.pt/twiki/bin/view/Education/CP/MaterialPedagogico}{Probability}\index{Haskell!Biblioteca!Probability}}
+\def\QuickCheck{\href{https://wiki.haskell.org/Introduction_to_QuickCheck1}{QuickCheck}\index{Haskell!QuickCheck}}
+\def\Unix{\href{https://en.wikipedia.org/wiki/Unix}{Unix}\index{Unix}}
+\def\R{I\!\!R\index{Números reais ($I\!\!R$)}}
+\def\TUG{TUG\index{TeX!TeX Users Group (TUG)}}
+\def\alt#1#2{\mathopen{[}#1 , #2\mathclose{]}\index{Combinador ``pointfree''!\emph{either}}}	% "either" is reserved...
+\def\ap#1#2{#1\,#2}
+\def\bang{{!}\index{Função!\emph{bang}}}
+\def\btree#1{\href{https://en.wikipedia.org/wiki/B-tree}{#1}\index{B-tree}}
+\def\B{\mathbb{B}\index{Booleans}}
+\def\CP{\href{https://haslab.github.io/CP/}{Cálculo de Programas}\index{Cálculo de Programas}}
+\def\N{\mathbb{N}\index{Números naturais ($I\!\!N$)}}
+\def\Q{\mathbb{Q}\index{Racionais}}
+\def\cata#1{\mathopen{\llparenthesis}#1\mathclose{\rrparenthesis}\index{Combinador ``pointfree''!\emph{cata}}}
+\def\cataList#1{\mathopen{\llparenthesis}#1\mathclose{\rrparenthesis}\index{Combinador ``pointfree''!\emph{cata}!Listas}}
+\def\anaList#1{\lanabracket#1\ranabracket\index{Combinador ``pointfree''!\emph{ana}!Listas}}
+\def\cataNat#1{\mathopen{\llparenthesis}#1\mathclose{\rrparenthesis}\index{Combinador ``pointfree''!\emph{cata}!Naturais}}
+\def\cp#1{\href{https://haslab.github.io/CP/}{#1}\index{Cálculo de Programas}}
+\def\dium{\htmladdnormallink{Departamento de Informática}{http://www.di.uminho.pt/}\index{U.Minho!Departamento de Informática}}
+\def\gloss#1{\href{https://hackage.haskell.org/package/gloss-1.13.1.1/docs/Graphics-Gloss.html}{#1}\index{Haskell!Gloss}}
+\def\graphviz#1{\href{https://www.graphviz.org/}{#1}\index{Graphviz}}
+\def\pd#1{\href{https://en.wikipedia.org/wiki/Dynamic_programming}{#1}\index{Programação!dinâmica}}
+\def\stack#1{\href{https://docs.haskellstack.org/en/stable/README/}{#1}\index{Haskell!Stack}}
+\def\xfig#1{\href{https://sourceforge.net/projects/mcj/}{#1}\index{X-fig}}
+\def\file#1{\texttt{#1}\index{Ficheiro!\texttt{#1}}}
+\def\ghci#1{\href{https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html}{#1}\index{Haskell!interpretador!GHCi}}
+\def\graphviz#1{\href{http://graphviz.org/}{#1}\index{Graphviz}}
+\def\webgraphviz#1{\href{http://www.webgraphviz.com/}{#1}\index{Graphviz!WebGraphviz}}
+\def\gcc#1{\href{https://www.gnu.org/software/gcc/}{#1}\index{GCC}}
+\def\pda#1{\href{https://en.wikipedia.org/wiki/Stack_machine\#Simple_compilers}{#1}\index{Stack machine}}
+\def\haskell#1{\href{http://www.haskell.org}{#1}\index{Haskell}}
+\def\haskellf#1{\texttt{#1}\index{Função!\texttt{#1}}}
+\def\hcata{cata\index{Combinador ``pointfree''!\emph{cata}}}
+\def\iso{\mathbin{\cong}\index{Relação de isomorfismo}}
+\def\kons#1{\underline{#1}\index{Combinador ``pointfree''!função constante}}
+\def\length{\mathit{length}\index{Função!\emph{length}}}
+\def\lhaskell#1{#1\index{Haskell!Literate Haskell}}
+\def\lhstotex#1{\href{https://hackage.haskell.org/package/lhs2tex}{#1}\index{\LaTeX!\texttt{lhs2TeX}}}
+\def\litp#1{\href{http://www.literateprogramming.com}{#1}\index{Programação!literária}}
+\def\lsystem#1{\href{https://en.wikipedia.org/wiki/L-system}{#1}\index{L-system}}
+\def\map#1{\mathsf{map}\ #1\index{Função!\emph{map}}}
+\def\for#1#2{\mathsf{for}\ #1 #2\index{Função!\emph{for}}}
+\def\material#1{\href{https://haslab.github.io/CP/Material/}{#1}\index{Cálculo de Programas!Material Pedagógico}}
+\def\p#1{\pi_{#1}\index{Função!$\pi_#1$}}
+\def\ana#1{\lanabracket#1\ranabracket\index{Combinador ``pointfree''!\emph{ana}}}
+\def\split#1#2{\mathopen{\langle}#1 , #2\mathclose{\rangle}\index{Combinador ``pointfree''!\emph{split}}} % <a,b,...z>
+\def\succ#1{\mathsf{succ}\ #1\index{Função!\emph{succ}}}
+\def\taylor#1{\href{https://en.wikipedia.org/wiki/Taylor_series}{#1}\index{Taylor series!Maclaurin series}}
+\def\texcmd#1{\texttt{#1}\index{\LaTeX!macro!\texttt{#1}}}
+\def\trans#1{\overline{#1\rule{0pt}{.6em}}\index{Combinador ``pointfree''!transposição}}
+\def\uncurry #1{\widehat{#1}\index{Função!\emph{uncurry}}}
+\def\wc#1{\href{http://pubs.opengroup.org/onlinepubs/9699919799/utilities/wc.html}{#1}\index{Unix shell!wc}}
+\def\xypic#1{\textsc{#1}\index{\LaTeX!pacote!XY-pic}}
+%----------------- Extracted from jnobasics.sty -------------------------------%
+\long\def\pdfout#1{\relax}
+\def\mcond#1#2#3{#1 \rightarrow #2 , #3}
+\newenvironment{lcbr}{\left\{\begin{array}{l}}{\end{array}\right.}
+\newenvironment{calculation}{\begin{eqnarray*}&&}{\end{eqnarray*}}
+\def\eg{\emph{eg.}}
+\def\esimo#1{#1${.\kern-.1em}^{\super{o}}$}
+\def\esima#1{#1${.\kern-.1em}^{\super{a}}$}
+\def\super#1{\mbox{{\scriptsize #1}}}
+\def\comp{\mathbin{\cdot}}
+\def\implied{\mathbin\Leftarrow}
+\def\deff{\stackrel{\rm def}{=}}          % Function definition symbol
+\def\kcomp{\mathbin{\bullet}}
+\def\conj#1#2{\mathopen{\langle} #1, #2 \mathclose{\rangle}}
+\def\start{&&}
+\def\more{\\&&}
+\def\qed{\\&\Box&}
+\def\just#1#2{\\ &#1& \rule{2em}{0pt} \{ \mbox{\rule[-.7em]{0pt}{1.8em} \small #2 \/} \} \nonumber\\ && }
+%----------------- Cross references -------------------------------------------%
+\newlabel{eq:fokkinga}{{3.95}{112}{The mutual-recursion law}{section.3.17}{}}
+%----------------- Importing/modifying isolatin1 ------------------------------%
+%\usepackage{isolatin1}
+%\catcode181=13  \def^^b5{\mu}				% 181, '265, "b5
+%\@ifundefined{lguill}{\def^^ab{``}}{\def^^ab{\lguill}}
+%\@ifundefined{rguill}{\def^^bb{''}}{\def^^bb{\rguill}}
+%\catcode186=13  \def^^ba{${\kern-.1em}^{\mbox{\scriptsize o}}$}      % 186, '272, "ba
+%\catcode183=13  \def^^b7{\comp}     % 183, '267, "b7
+%----------------- WWW interfacing desabled -----------------------------------%
+\let\pisca=\relax
+\def\quoteId#1#2{\textsl{#1}}
+\def\quoteUrl#1#2{\texttt{#2}}
+\let\htmladdnormallink=\quoteId             % HTML links disabled by default
+%----------------- Shortcuts --------------------------------------------------%
+\def\Haskell{\haskell{Haskell}}
+\def\Graphviz{\graphviz{Graphviz}}
+\def\WebGraphviz{\webgraphviz{WebGraphviz}}
+\def\LSystems{\lsystem{L-Systems}}
+\def\LSystem{\lsystem{L-System}}
+%----------------- Date -------------------------------------------------------%
+\def\mydate{
+\ifcase\month\or
+ Janeiro\or Fevereiro\or Março\or Abril\or Maio\or Junho\or Julho\or Agosto\or Setembro\or Outubro\or Novembro\or Dezembro\fi \ de \number\year
+}
+%----------------- Problemas ----------------------------------------------------%
+\newcount\pn \pn=1 % Problem number
+%\def\Problema{\section*{Problema \number\pn}\global\advance\pn by 1}
+\def\Problema{\section*{Problema \number\pn}\global\advance\pn by 1}
+
+%----------------- fim ----------------------------------------------------------%
+