{-
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)
|