{-# LANGUAGE PatternSignatures #-}
{- 
Purpose:
  "Try out" the use of catamorphism to simplify an expression
  as far as possible.
Reference:
  Post:
    http://www.nabble.com/Re%3A-Is-there-already-an-abstraction-for-this--p19641692.html
  Headers:
    From: wren ng thornton
    Newsgroups: gmane.comp.lang.haskell.cafe
    Subject: Re: Is there already an abstraction for this?
    Date: Wed, 24 Sep 2008 00:10:29 -0400
-}
module Main where

import Array

data Arity0 con var --nullary operators
  = OpCon con -- constant
  | OpVar var -- variable
  deriving(Show)

data ArityN arity0
  = Op0 arity0
  | (:+) (ArityN arity0) (ArityN arity0)
  | (:*) (ArityN arity0) (ArityN arity0)
  deriving(Show)

infixl 6 :+
infixl 7 :*

instance Functor ArityN where
  fmap f (Op0 e) =  Op0 (f e)
  fmap f ((:+) e0 e1) = (:+) (fmap f e0) (fmap f e1)
  fmap f ((:*) e0 e1) = (:*) (fmap f e0) (fmap f e1)

data ConBool --boolean constants
  = BoolFalse
  | BoolTrue
  deriving(Enum,Show,Ord,Eq,Bounded,Ix)

data VarName --varable names
  = V0
  | V1
  | V2
  deriving(Enum,Show,Ord,Eq,Bounded,Ix)

bool_eval :: ArityN (Arity0 ConBool var) -> ArityN (Arity0 ConBool var)

bool_eval e = case e of
  { (Op0 (OpCon BoolTrue ) :+ _                     ) -> Op0 (OpCon BoolTrue)
  ; (_                     :+ Op0 (OpCon BoolTrue ) ) -> Op0 (OpCon BoolTrue)
  ; (Op0 (OpCon BoolFalse) :+ e1                    ) -> e1
  ; (e0                    :+ Op0 (OpCon BoolFalse) ) -> e0
  ; (Op0 (OpCon BoolFalse) :* _                     ) -> Op0 (OpCon BoolFalse)
  ; (_                     :* Op0 (OpCon BoolFalse) ) -> Op0 (OpCon BoolFalse)
  ; (e0                    :+ e1                    ) -> (bool_eval e0) :+ (bool_eval e1)
  ; (e0                    :* e1                    ) -> (bool_eval e0) :* (bool_eval e1)
  ; e                                                 -> e
  }

main = do
  let bool_f::ArityN (Arity0 ConBool VarName) = Op0 (OpCon BoolFalse)
  let bool_expr_f_plus_v0 = bool_f :+ Op0 (OpVar V0)
  putStr "bool_expr:f+v0="
  print bool_expr_f_plus_v0
  let bool_eval_f_plus_v0 = bool_eval bool_expr_f_plus_v0
  putStr "bool_eval:f+v0="
  print bool_eval_f_plus_v0
  let bool_expr_f_plus_f_plus_v0 = bool_f :+ bool_expr_f_plus_v0
  putStr "bool_expr:f+f+f+v0="
  print bool_expr_f_plus_f_plus_v0
  let bool_eval_f_plus_f_plus_v0 = bool_eval bool_expr_f_plus_f_plus_v0
  putStr "bool_eval:f+f+v0="
  print bool_eval_f_plus_f_plus_v0