{-
    Haskell version of ...

! Lisp-like functions which allow easy hand translation from Lisp to Hope+ 
! Started by Tony Kitto on 30th March 1988 
! Changes Log 
! 18-05-88 added LUT functions and regularized assoc
! 25-05-88 added Lisptochar and DisplayLUT

Haskell version::

    23-06-93 JSM initial version

-}

module Lisplikefns (
    Token, Lisplist(..), LUT, 
    mkLisplist, strToToken, tv,
    atom, car, cdr, cadr, caddr, cadddr, assoc,
    newLUT, addtoLUT, getLUT
)

where

type Token = String -- "(" or ")" or "Lisp Symbol"

data Lisplist = Nil | Atom Token | Cons (Lisplist, Lisplist) deriving (Eq,Show{-was:Text-})

-- These functions create a Lisplist from a list of characters 

mkLisplist :: [Token] -> Lisplist
mkLisplist ("(":t) = if r /= [] then Nil else l
		     where (r, l) = sublist t
mkLisplist _       = Nil

sublist :: [Token] -> ([Token], Lisplist)
sublist []      = ([], Nil)
sublist ("(":t) = (r2, Cons (l1, l2))
		  where (r1, l1) = sublist t
		        (r2, l2) = sublist r1
sublist (")":t) = (t, Nil)
sublist (h:t)   = (r, Cons (Atom h, l))
		  where (r, l) = sublist t

strToToken :: String -> [Token]
strToToken "" = []
strToToken s  = a : strToToken b
		where (a, b) = getToken s
                         
getToken :: String -> (Token, String)
getToken ""                           = ([], "")
getToken (h:t) | h == ' '             = getToken t
	       | h == '(' || h == ')' = ([h], t)
	       | otherwise            = (h:a, b)
		 where (a, b) = restOfToken t

restOfToken :: String -> (Token, String)
restOfToken ""                                       = ([], "")
restOfToken (h:t) | h == '(' || h == ')' || h == ' ' = ([], h:t)
		  | otherwise                        = (h:a, b)
		    where (a, b) = restOfToken t

tv :: Lisplist -> Token
tv (Atom x) = x
tv _ 	    = error "Not an atom"


-- These functions provide simple Lisplist operations

atom :: Lisplist -> Bool
atom (Atom x) = True
atom _ 	      = False

car :: Lisplist -> Lisplist
car (Cons (x, y)) = x
car _ 	    	  = Nil

cdr :: Lisplist -> Lisplist
cdr (Cons (x, y)) = y
cdr _ 	    	  = Nil

cadr :: Lisplist -> Lisplist
cadr = car . cdr

caddr :: Lisplist -> Lisplist
caddr = car . cdr . cdr

cadddr :: Lisplist -> Lisplist
cadddr = car . cdr . cdr . cdr

assoc :: (Lisplist, Lisplist) -> Lisplist
assoc (term, Cons (x, y)) = case x of
    Cons (head@(Atom key), rest) | term == head -> x 
    	    	    	    	 | otherwise -> assoc (term, y)
    _ -> Nil
assoc (_, _) 	    	  = Nil

{-
  These functions provide more complex operations based on a Lisp-like       
  functionality, they do not exactly match the equivalent Lisp functions
-}

type LUTentry = (Token, [Lisplist] )
data LUT = Empty | Node (LUT, LUTentry, LUT) deriving (Show{-was:Text-})


newLUT :: LUT
newLUT = Empty

addtoLUT :: (Token, Lisplist, LUT) -> LUT
addtoLUT (k, l, Empty) = Node (Empty, (k, [l]), Empty)
addtoLUT (k, l, Node (left, (k1, kl), right)) 
    | k == k1   = Node (left, (k1, l:kl), right)
    | k <  k1   = Node (addtoLUT (k, l, left), (k1, kl), right)
    | otherwise = Node (left, (k1, kl), addtoLUT (k, l, right))

getLUT :: (Token, LUT) -> [Lisplist]
getLUT (t, Empty) = []
getLUT (t, Node (left, (k, kl), right))
    | t == k    = kl
    | t <  k    = getLUT (t, left)
    | otherwise = getLUT (t, right)