1 {-
    2     Haskell version of ...
    3 
    4 ! Lisp-like functions which allow easy hand translation from Lisp to Hope+ 
    5 ! Started by Tony Kitto on 30th March 1988 
    6 ! Changes Log 
    7 ! 18-05-88 added LUT functions and regularized assoc
    8 ! 25-05-88 added Lisptochar and DisplayLUT
    9 
   10 Haskell version::
   11 
   12     23-06-93 JSM initial version
   13 
   14 -}
   15 
   16 module Lisplikefns (
   17     Token, Lisplist(..), LUT, 
   18     mkLisplist, strToToken, tv,
   19     atom, car, cdr, cadr, caddr, cadddr, assoc,
   20     newLUT, addtoLUT, getLUT
   21 )
   22 
   23 where
   24 
   25 type Token = String -- "(" or ")" or "Lisp Symbol"
   26 
   27 data Lisplist = Nil | Atom Token | Cons (Lisplist, Lisplist) deriving (Eq,Show{-was:Text-})
   28 
   29 -- These functions create a Lisplist from a list of characters 
   30 
   31 mkLisplist :: [Token] -> Lisplist
   32 mkLisplist ("(":t) = if r /= [] then Nil else l
   33                      where (r, l) = sublist t
   34 mkLisplist _       = Nil
   35 
   36 sublist :: [Token] -> ([Token], Lisplist)
   37 sublist []      = ([], Nil)
   38 sublist ("(":t) = (r2, Cons (l1, l2))
   39                   where (r1, l1) = sublist t
   40                         (r2, l2) = sublist r1
   41 sublist (")":t) = (t, Nil)
   42 sublist (h:t)   = (r, Cons (Atom h, l))
   43                   where (r, l) = sublist t
   44 
   45 strToToken :: String -> [Token]
   46 strToToken "" = []
   47 strToToken s  = a : strToToken b
   48                 where (a, b) = getToken s
   49                          
   50 getToken :: String -> (Token, String)
   51 getToken ""                           = ([], "")
   52 getToken (h:t) | h == ' '             = getToken t
   53                | h == '(' || h == ')' = ([h], t)
   54                | otherwise            = (h:a, b)
   55                  where (a, b) = restOfToken t
   56 
   57 restOfToken :: String -> (Token, String)
   58 restOfToken ""                                       = ([], "")
   59 restOfToken (h:t) | h == '(' || h == ')' || h == ' ' = ([], h:t)
   60                   | otherwise                        = (h:a, b)
   61                     where (a, b) = restOfToken t
   62 
   63 tv :: Lisplist -> Token
   64 tv (Atom x) = x
   65 tv _        = error "Not an atom"
   66 
   67 
   68 -- These functions provide simple Lisplist operations
   69 
   70 atom :: Lisplist -> Bool
   71 atom (Atom x) = True
   72 atom _        = False
   73 
   74 car :: Lisplist -> Lisplist
   75 car (Cons (x, y)) = x
   76 car _              = Nil
   77 
   78 cdr :: Lisplist -> Lisplist
   79 cdr (Cons (x, y)) = y
   80 cdr _              = Nil
   81 
   82 cadr :: Lisplist -> Lisplist
   83 cadr = car . cdr
   84 
   85 caddr :: Lisplist -> Lisplist
   86 caddr = car . cdr . cdr
   87 
   88 cadddr :: Lisplist -> Lisplist
   89 cadddr = car . cdr . cdr . cdr
   90 
   91 assoc :: (Lisplist, Lisplist) -> Lisplist
   92 assoc (term, Cons (x, y)) = case x of
   93     Cons (head@(Atom key), rest) | term == head -> x 
   94                                  | otherwise -> assoc (term, y)
   95     _ -> Nil
   96 assoc (_, _)                = Nil
   97 
   98 {-
   99   These functions provide more complex operations based on a Lisp-like       
  100   functionality, they do not exactly match the equivalent Lisp functions
  101 -}
  102 
  103 type LUTentry = (Token, [Lisplist] )
  104 data LUT = Empty | Node (LUT, LUTentry, LUT) deriving (Show{-was:Text-})
  105 
  106 
  107 newLUT :: LUT
  108 newLUT = Empty
  109 
  110 addtoLUT :: (Token, Lisplist, LUT) -> LUT
  111 addtoLUT (k, l, Empty) = Node (Empty, (k, [l]), Empty)
  112 addtoLUT (k, l, Node (left, (k1, kl), right)) 
  113     | k == k1   = Node (left, (k1, l:kl), right)
  114     | k <  k1   = Node (addtoLUT (k, l, left), (k1, kl), right)
  115     | otherwise = Node (left, (k1, kl), addtoLUT (k, l, right))
  116 
  117 getLUT :: (Token, LUT) -> [Lisplist]
  118 getLUT (t, Empty) = []
  119 getLUT (t, Node (left, (k, kl), right))
  120     | t == k    = kl
  121     | t <  k    = getLUT (t, left)
  122     | otherwise = getLUT (t, right)
  123