81 lines
2.3 KiB
Plaintext
81 lines
2.3 KiB
Plaintext
main :: [sys_message]
|
|
main = [Stdout (lay [show (take 15 (run 2 primeprog)),
|
|
show (take 20 fracprimes)])]
|
|
|
|
primeprog :: [(num,num)]
|
|
primeprog = fromjust (prog ("17/91 78/85 19/51 23/38 29/33 77/29 95/23 77/19 "
|
|
++ "1/17 11/13 13/11 15/14 15/2 55/1"))
|
|
|
|
fracprimes :: [num]
|
|
fracprimes = [fromjust k | k<-map fracprime (run 2 primeprog); isjust k]
|
|
|
|
fracprime :: num->maybe num
|
|
fracprime = f 0
|
|
where f 1 1 = Nothing
|
|
f n 1 = Just n
|
|
f n x = Nothing, if x mod 2 ~= 0
|
|
f n x = f (n+1) (x div 2), otherwise
|
|
|
|
run :: num->[(num,num)]->[num]
|
|
run n prog = [n], if ~isjust n'
|
|
= n : run (fromjust n') prog, otherwise
|
|
where n' = step n prog
|
|
|
|
step :: num->[(num,num)]->maybe num
|
|
step x [] = Nothing
|
|
step x ((n,d):xs) = Just (x*n div d), if x*n mod d = 0
|
|
= step x xs, otherwise
|
|
|
|
maybe * ::= Nothing | Just *
|
|
|
|
isjust :: maybe *->bool
|
|
isjust (Just x) = True
|
|
isjust Nothing = False
|
|
|
|
fromjust :: maybe *->*
|
|
fromjust (Just x) = x
|
|
|
|
prog :: [char]->maybe [(num, num)]
|
|
prog xs = Just [], if trim xs = []
|
|
= Nothing, if ~isjust fp \/ ~isjust rp
|
|
= Just (fr : fromjust rp), otherwise
|
|
where fp = frac xs
|
|
Just (fr, xs') = fp
|
|
rp = prog xs'
|
|
|
|
frac :: [char]->maybe ((num,num), [char])
|
|
frac xs = Nothing, if ~isjust np \/ ~isjust sl \/ ~isjust dp
|
|
= Just ((n, d), xs'''), otherwise
|
|
where np = numb xs
|
|
Just (n, xs') = np
|
|
sl = match '/' (trim xs')
|
|
Just xs'' = sl
|
|
dp = numb xs''
|
|
Just (d, xs''') = dp
|
|
|
|
numb :: [char]->maybe (num, [char])
|
|
numb xs = Nothing, if n=[]
|
|
= Just (numval n, r), otherwise
|
|
where (n, r) = span "0123456789" (trim xs)
|
|
|
|
match :: *->[*]->maybe [*]
|
|
match m [] = Nothing
|
|
match m (m:xs) = Just xs
|
|
match m (x:xs) = Nothing
|
|
|
|
span :: [*]->[*]->([*],[*])
|
|
span match [] = ([], [])
|
|
span match (x:xs) = ([], x:xs), if ~(x $in match)
|
|
= (x:r, xs'), otherwise
|
|
where (r, xs') = span match xs
|
|
|
|
in :: *->[*]->bool
|
|
in x [] = False
|
|
in x (x:xs) = True
|
|
in x (y:xs) = x $in xs
|
|
|
|
trim :: [char]->[char]
|
|
trim [] = []
|
|
trim (c:xs) = trim xs, if c='\t' \/ c='\n' \/ c=' '
|
|
trim (c:xs) = c:xs
|