module CF

where 

import Data.List

type Name = String
type CF a = Name -> [a]

fullRange ::  (Enum a, Bounded a) => [a]
fullRange = [minBound .. maxBound]

top :: (Enum a, Bounded a) => CF a
top = \ _ -> fullRange 

bottom :: CF a
bottom = \ _ -> [] 

join :: (Eq a, Enum a, Bounded a) => CF a -> CF a -> CF a
join f g x = union (f x) (g x)

meet :: (Eq a, Enum a, Bounded a) => CF a -> CF a -> CF a
meet f g x = intersect (f x) (g x) 

type Action a = CF a -> CF a 

skip :: Action a 
skip = id

info :: (Enum a, Bounded a) => Action a -> CF a
info action = action top

update :: Eq a => Name -> [a] -> Action a
update x c f y | x == y    = intersect c (f y)
               | otherwise = f y

replace :: Name -> [a] -> Action a
replace x c f y | x == y    = c 
                | otherwise = f y

if_then_else :: (CF a -> Bool) 
                 -> Action a -> Action a -> Action a 
if_then_else condition action1 action2 = \ f -> 
   if condition f then (action1 f) else (action2 f) 

infixl 2 ##

(##) :: Action a -> Action a -> Action a
a1 ## a2 = a2 . a1

while :: (CF a -> Bool) -> Action a -> Action a
while condition action = 
  \f -> if condition f
        then (action ## (while condition action)) f
        else f

encode :: (Enum a,Enum b) => a -> b
encode = toEnum . fromEnum 

isBool :: (Eq a, Enum a) => Name -> Action a
isBool x = update x (map encode (fullRange :: [Bool]))

isChar :: (Eq a, Enum a) => Name -> Action a
isChar x = update x (map encode (fullRange :: [Char]))

asciiRange = [' ' .. '~'] 

data Ascii = Ascii String deriving Eq

instance Show Ascii where 
   show (Ascii xs) = show xs

instance Bounded Ascii where 
  minBound = Ascii [' ']
  maxBound = Ascii (take 9 (repeat '~'))

f :: Int -> Int ->  [Int]
f x d = let 
          (q,r) = quotRem x d 
        in if q == 0 then [r] else r : (f q d)

instance Enum Ascii where 
  toEnum x = let 
     d = fromEnum '~' - fromEnum ' '
   in 
     Ascii (map (\ z -> toEnum (z + 32)) (f x d))
  fromEnum (Ascii [c]) = fromEnum c - 32
  fromEnum (Ascii (c:cs)) = let 
     d = fromEnum '~' - fromEnum ' '
    in 
      (fromEnum c - 32) + d * (fromEnum (Ascii cs))

isAscii :: (Eq a, Enum a) => Name -> Action a
isAscii x = replace x (map encode (fullRange :: [Ascii]))

data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun 
   deriving (Eq,Show,Enum,Bounded)

isDay :: (Eq a, Enum a) => Name -> Action a
isDay x = update x (map encode (fullRange :: [Day]))

data Gender = Male | Female 
   deriving (Eq,Show,Enum,Bounded)

isGender :: (Eq a, Enum a, Bounded a) => Name -> Action a
isGender x = update x (map encode (fullRange :: [Gender]))

isAge :: (Eq a, Enum a) => Name -> Action a
isAge x = replace x (map encode ([0 .. 120] :: [Int]))

partialAnswer :: (Eq a, Enum a,Enum b) => 
                  Name -> [b] -> Action a
partialAnswer x y = replace x (map encode y)

fullAnswer :: (Eq a, Enum a,Enum b) => Name -> b -> Action a
fullAnswer x y = replace x [encode y]

instruction :: (Eq a, Enum a, Bounded a) => Action a 
instruction = 
   isAscii  "given name"  ##
   isAscii  "surname"     ##
   isGender "gender"      ##
   isBool   "married"     ##
   isAge    "age"

form :: (Eq a, Enum a, Bounded a) => CF a 
form = info instruction

answer :: (Eq a, Enum a, Bounded a) => Action a 
answer = fullAnswer "given name" (Ascii "Jan")     ##
         fullAnswer "surname" (Ascii "van Eijck")  ##
         fullAnswer "gender" Male                  ##
         partialAnswer "age" [40..70]         

marriedQ :: (Eq a, Enum a, Bounded a) => Action a
marriedQ = if_then_else 
                 (\f -> all (> 15) (map encode (f "age")))
                 (isBool "married")
                 skip