Initial code structure
This commit is contained in:
Tiago Sousa
parent
c683bb725b
commit
e5ddbe3ec5
34 changed files with 6824 additions and 0 deletions
205
cp2223t/BTree.hs
Normal file
205
cp2223t/BTree.hs
Normal file
|
|
@ -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 wellknown 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 anticlockwise
|
||||
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 onebyone 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 ----------------------------------
|
||||
260
cp2223t/Cp.hs
Normal file
260
cp2223t/Cp.hs
Normal file
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
2119
cp2223t/Cp2223data.hs
Normal file
2119
cp2223t/Cp2223data.hs
Normal file
File diff suppressed because it is too large
Load diff
221
cp2223t/Exp.hs
Normal file
221
cp2223t/Exp.hs
Normal file
|
|
@ -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'
|
||||
--}
|
||||
-------------------------------------------------------------------------------
|
||||
60
cp2223t/FTree.hs
Normal file
60
cp2223t/FTree.hs
Normal file
|
|
@ -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
|
||||
|
||||
228
cp2223t/LTree.hs
Normal file
228
cp2223t/LTree.hs
Normal file
|
|
@ -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 ----------------------------------
|
||||
|
||||
216
cp2223t/List.hs
Normal file
216
cp2223t/List.hs
Normal file
|
|
@ -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 ------------------------------------------------------------
|
||||
26
cp2223t/ListUtils.hs
Normal file
26
cp2223t/ListUtils.hs
Normal file
|
|
@ -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'
|
||||
17
cp2223t/Makefile
Normal file
17
cp2223t/Makefile
Normal file
|
|
@ -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
|
||||
49
cp2223t/NEList.hs
Normal file
49
cp2223t/NEList.hs
Normal file
|
|
@ -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))
|
||||
107
cp2223t/Nat.hs
Normal file
107
cp2223t/Nat.hs
Normal file
|
|
@ -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 ----------------------------------------
|
||||
697
cp2223t/Probability.hs
Normal file
697
cp2223t/Probability.hs
Normal file
|
|
@ -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
|
||||
|
||||
-}
|
||||
|
||||
209
cp2223t/RelCalc.hs
Normal file
209
cp2223t/RelCalc.hs
Normal file
|
|
@ -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]
|
||||
|
||||
53
cp2223t/Rose.hs
Normal file
53
cp2223t/Rose.hs
Normal file
|
|
@ -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]
|
||||
16
cp2223t/Show.hs
Normal file
16
cp2223t/Show.hs
Normal file
|
|
@ -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)
|
||||
|
||||
96
cp2223t/St.hs
Normal file
96
cp2223t/St.hs
Normal file
|
|
@ -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
|
||||
--------------------------------------------------------------------------
|
||||
580
cp2223t/Svg.hs
Normal file
580
cp2223t/Svg.hs
Normal file
|
|
@ -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
|
||||
|
||||
---
|
||||
84
cp2223t/cp2223t.bib
Normal file
84
cp2223t/cp2223t.bib
Normal file
|
|
@ -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.}
|
||||
}
|
||||
|
||||
85
cp2223t/cp2223t.idx
Normal file
85
cp2223t/cp2223t.idx
Normal file
|
|
@ -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}
|
||||
6
cp2223t/cp2223t.ilg
Normal file
6
cp2223t/cp2223t.ilg
Normal file
|
|
@ -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.
|
||||
62
cp2223t/cp2223t.ind
Normal file
62
cp2223t/cp2223t.ind
Normal file
|
|
@ -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}
|
||||
1186
cp2223t/cp2223t.lhs
Normal file
1186
cp2223t/cp2223t.lhs
Normal file
File diff suppressed because it is too large
Load diff
BIN
cp2223t/cp2223t.pdf
Normal file
BIN
cp2223t/cp2223t.pdf
Normal file
Binary file not shown.
242
cp2223t/cp2223t.sty
Normal file
242
cp2223t/cp2223t.sty
Normal file
|
|
@ -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{\\ & \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 ----------------------------------------------------------%
|
||||
|
||||
BIN
cp2223t/cp2223t_media/.DS_Store
vendored
Normal file
BIN
cp2223t/cp2223t_media/.DS_Store
vendored
Normal file
Binary file not shown.
BIN
cp2223t/cp2223t_media/acmccs.png
Normal file
BIN
cp2223t/cp2223t_media/acmccs.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 214 KiB |
BIN
cp2223t/cp2223t_media/acmccsX.jpg
Normal file
BIN
cp2223t/cp2223t_media/acmccsX.jpg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 405 KiB |
BIN
cp2223t/cp2223t_media/tapete1.png
Normal file
BIN
cp2223t/cp2223t_media/tapete1.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 25 KiB |
BIN
cp2223t/cp2223t_media/tapete2.png
Normal file
BIN
cp2223t/cp2223t_media/tapete2.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 33 KiB |
BIN
cp2223t/cp2223t_media/tapete3.png
Normal file
BIN
cp2223t/cp2223t_media/tapete3.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 44 KiB |
BIN
cp2223t/cp2223t_media/tapete4.png
Normal file
BIN
cp2223t/cp2223t_media/tapete4.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 84 KiB |
BIN
cp2223t/cp2223t_media/tapete5.png
Normal file
BIN
cp2223t/cp2223t_media/tapete5.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 270 KiB |
BIN
cp2223t/cp2223t_media/tapete_ex.png
Normal file
BIN
cp2223t/cp2223t_media/tapete_ex.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 55 KiB |
BIN
cp2223t/cp2223t_media/wcup2022.png
Normal file
BIN
cp2223t/cp2223t_media/wcup2022.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 209 KiB |
Loading…
Reference in a new issue