module LambdaMatchPatterns where

import ControlMonadMatch
import ControlMonadPattern
import ControlMonadMatchInstances
import Control.Monad
import Data.Array
import Debug.Trace

-- our own array list variant, with pattern matching

type List a = Array Int a

-- constructors, tests, deconstructors

nilA :: List a
nilA      = array (0,-1) []
consA h t = listArray (low,high+1) (h:elems t)
  where (low,high) = bounds t

isNilA l = bounds l == (0,-1)

headA l | not (isNilA l) = l!0
tailA l | not (isNilA l) = listArray (low,high-1) (tail $ elems l)
  where (low,high) = bounds l

snocA h t = listArray (low,high+1) (elems t++[h])
  where (low,high) = bounds t

lastA l | not (isNilA l) = l!(snd $ bounds l)
initA l | not (isNilA l) = listArray (low,high-1) (init $ elems l)
  where (low,high) = bounds l

-- we define our own pattern constructors, cons and (non-reversed) snoc view
-- these are refutable; irrefutable pattern constructors would omit the guards

consAP h t l = do { Match $ guard $ not (isNilA l); h (headA l); t (tailA l) }
nilAP      l = do { Match $ guard $      isNilA l }

snocAP t h l = do { Match $ guard $ not (isNilA l); t (initA l); h (lastA l) }

---------------------------------------------------------------------- examples

anA = consA 1 $ consA 2 $ consA 3 $ consA 4 nilA

mapA f = splice $ (vV $ \h t-> Vv $ consAP (h|!) (t|!) ==> (f (h|?) `consA` mapA f (t|?)))
              +++ (                 nilAP              ==> nilA)

foldA  f n = splice $ (vV $ \h t-> Vv $ consAP (h|!) (t|!) ==> ((h|?) `f` (foldA f n (t|?))))
                  +++ (                 nilAP              ==> n)

foldA' f n = splice $ (vV $ \h t-> Vv $ snocAP (t|!) (h|!) ==> ((h|?) `f` (foldA' f n (t|?))))
                  +++ (                 nilAP              ==> n)

palindrome :: (Eq a) => List a -> Bool
palindrome x = (x >|) $ splice $  -- hugs gives a funny error without this eta-expansion..
      (nilAP 
        ==> True)
  +++ (consAP wildP nilAP 
        ==> True)
  +++ (vV $ \start middle end-> Vv $ ( (start|!) `consAP` (middle|!) `snocAP` (end|!) ) 
        ==> ( ((start|?) == (end|?)) && palindrome (middle|?)) )

main = do
  putStrLn $ "anA                               = "++show (anA)
  putStrLn $ "mapA (+1) anA                     = "++show (mapA (+1) anA)
  putStrLn $ "foldA (+) 0 anA                   = "++show (foldA (+) 0 anA)
  putStrLn $ "foldA (*) 1 anA                   = "++show (foldA (*) 1 anA)
  putStrLn $ "foldA  consA nilA anA             = "++show (foldA  consA nilA anA)
  putStrLn $ "foldA' consA nilA anA             = "++show (foldA' consA nilA anA)
  putStrLn $ "palindrome anA                    = "++show (palindrome anA)
  putStrLn $ "palindrome (foldA' consA anA anA) = " ++show (palindrome (foldA' consA anA anA))