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