--------------------
-- Enum, Bounded, Eq, Ord and Show instances for (total) finite functions
-- Fritz Ruehr * Spring 2006
--------------------

module FinFun where

instance (Bounded a, Bounded b) => Bounded (a,b) where
  minBound = (minBound, minBound)
  maxBound = (maxBound, maxBound)


instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a,b) where
  toEnum k = (l,r)
             where (i,j) = divMod k (size r)
                   (l,r) = (toEnum i, toEnum j)

  fromEnum  (a,b) = sumProd (size b) (fromEnum a) (fromEnum b)


instance (Enum a, Bounded a, Enum b, Bounded b) => Bounded (a->b) where
  minBound = toEnum 0
  maxBound a = b 
               where b = toEnum (size b - 1)


instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a -> b) where
  toEnum k x = y
               where y = toEnum (digits !! fromEnum x)
                     digits = reverse (unbase (size y) k) ++ repeat 0

  fromEnum f = baser b $ map (fromEnum . f) $ full
               where b = size (f minBound)


instance (Enum a, Bounded a, Eq b) => Eq (a->b) where
  (==) f g = and [ f x==g x | x<-full ]


instance (Enum a, Bounded a, Enum b, Bounded b, Eq b) => Ord (a -> b) where
  compare f g = compare (fromEnum f) (fromEnum g)


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

size (x::a) = 1 + fromEnum (maxBound :: a) - fromEnum (minBound :: a)


{-
instance (Enum a, Bounded a, Show a, Show b) => Show (a->b) where
  show f = (prefix . drop 2 . foldr1 (.) clauses) ")"
           where prefix = showString "(\\x -> case x of "
                 clauses = [ fmt x (f x) | x<-full ]
                 fmt x y = ("; "++) . shows x . (" -> "++) . shows y
-}

-- alternate show for functions (more like truth tables)
-- (toggle with above definition)

-- {-
instance (Enum a, Bounded a, {-Enum b,-} Show a, Show b) => Show (a->b) where
  show f = unlines [ tab x (f x) | x<-full ]
           where tab x y = show x ++ '\t' : show y
           -- where tab x y = show (fromEnum x) ++ '\t' : show (fromEnum y)
-- -}


--------------------
-- positional notation conversions

sumProd b x y = b * x + y
swap (x,y) = (y,x)

base    b = foldl         ( sumProd b) 0
unbase  b = unfoldl (==0) (`divMod` b)

baser   b = foldr         (flip   ( sumProd b)) 0
unbaser b = unfoldr (==0) (swap . (`divMod` b))

unfoldr p f x = if p x then [] else a : (unfoldr p f y)
                where (a,y) = f x

unfoldl p f x = g x []
                where g x a = if p x then a else g r (y:a)
                              where (r,y) = f x

--------------------
-- Sample types and functions

data Color = Red | Orange | Yellow | Green | Blue | Purple
             deriving (Eq, Ord, Enum, Bounded, Show, Read)

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


data A = A | B | C  deriving (Eq, Ord, Enum, Bounded, Show)
data X = X | Y      deriving (Eq, Ord, Enum, Bounded, Show)

showall (x::a) = mapM_ (putStrLn . show) (full :: [a])

t0 = showall (const X :: X->X)
t1 = showall (const X :: A->X)
t2 = showall (const A :: X->A)
t3 = showall (const A :: A->A)


type HOB = (Bool -> Bool) -> Bool -> Bool

notty f = not . f . not


bop k = toEnum    k :: Bool -> Bool -> Bool
nop f = fromEnum (f :: Bool -> Bool -> Bool)

demor  x y = not (not x && not y)
demand x y = not (not x || not y)


----------------------------------------