progs/haskell/re.hs
author Christian Urban <christian dot urban at kcl dot ac dot uk>
Tue, 14 Jun 2016 12:37:46 +0100
changeset 201 2585e2a7a7ab
parent 156 6a43ea9305ba
child 359 fedc16924b76
permissions -rw-r--r--
updated
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     1
import System.Environment
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     2
import Data.List
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     3
import Text.Printf
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     4
import Control.Exception
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     5
import System.CPUTime
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     6
import Control.Parallel.Strategies
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     7
import Control.Monad
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     8
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
     9
lim :: Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    10
lim = 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    11
-- lim = 10^6
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    12
 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    13
time :: (Num t, NFData t) => t -> IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    14
time y = do
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    15
    start <- getCPUTime
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    16
    replicateM_ lim $ do
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    17
        x <- evaluate $ 1 + y
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    18
        rdeepseq x `seq` return ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    19
    end   <- getCPUTime
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    20
    let diff = (fromIntegral (end - start)) / (10^12)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    21
    printf "%0.9f\n" (diff :: Double)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    22
    return ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    23
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    24
data Rexp =
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    25
   ZERO 
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    26
 | ONE 
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    27
 | CHAR Char
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    28
 | ALT Rexp Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    29
 | SEQ Rexp Rexp 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    30
 | STAR Rexp 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    31
 | RECD String Rexp deriving (Eq, Show) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    32
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    33
data Value =
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    34
   Empty
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    35
 | Chr Char
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    36
 | Sequ Value Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    37
 | Lf Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    38
 | Rg Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    39
 | Stars [Value]
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    40
 | Rec String Value deriving (Eq, Show) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    41
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    42
string_repeat :: String -> Int -> String
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    43
string_repeat s n = concat (replicate n s)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    44
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    45
sequ :: [Char] -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    46
sequ s = case s of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    47
  [] -> ONE
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    48
  [c] -> CHAR c
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    49
  c:cs -> SEQ (CHAR c) (sequ cs)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    50
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    51
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    52
str :: String -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    53
str s = sequ s
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    54
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    55
plus :: Rexp -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    56
plus r = SEQ r (STAR r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    57
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    58
(\/) :: Rexp -> Rexp -> Rexp 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    59
r1 \/ r2 = ALT r1 r2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    60
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    61
(~~) :: Rexp -> Rexp -> Rexp 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    62
r1 ~~ r2 = SEQ r1 r2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    63
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    64
($$) :: String -> Rexp -> Rexp 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    65
x $$ r = RECD x r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    66
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    67
alts :: [Rexp] -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    68
alts rs = case rs of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    69
  [] -> ZERO
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    70
  [r] -> r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    71
  r:rs -> foldl (ALT) r rs
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    72
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    73
size :: Rexp -> Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    74
size r = case r of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    75
  ZERO -> 1
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    76
  ONE -> 1
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    77
  CHAR _ -> 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    78
  ALT r1 r2 -> 1 + (size r1) + (size r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    79
  SEQ r1 r2 -> 1 + (size r1) + (size r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    80
  STAR r -> 1 + (size r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    81
  RECD _ r -> 1 + (size r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    82
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    83
nullable :: Rexp -> Bool
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    84
nullable r = case r of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    85
  ZERO -> False
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    86
  ONE -> True
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    87
  CHAR _ -> False
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    88
  ALT r1 r2 -> nullable(r1) || nullable(r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    89
  SEQ r1 r2 -> nullable(r1) && nullable(r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    90
  STAR _ -> True
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    91
  RECD _ r -> nullable(r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    92
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    93
der :: Char -> Rexp -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    94
der c r = case r of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    95
  ZERO -> ZERO
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    96
  ONE -> ZERO
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
    97
  CHAR d -> if c == d then ONE else ZERO
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    98
  ALT r1 r2 -> ALT (der c r1) (der c r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
    99
  SEQ r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   100
      if nullable r1 then ALT (SEQ (der c r1) r2) (der c r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   101
      else SEQ (der c r1) r2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   102
  STAR r -> SEQ (der c r) (STAR r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   103
  RECD _ r -> der c r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   104
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   105
ders :: [Char] -> Rexp -> Rexp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   106
ders s r = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   107
  [] -> r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   108
  c:s -> ders s (der c r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   109
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   110
flatten :: Value -> String
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   111
flatten v = case v of 
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   112
  Empty -> ""
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   113
  Chr c -> [c]
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   114
  Lf v -> flatten v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   115
  Rg v -> flatten v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   116
  Sequ v1 v2 -> flatten v1 ++ flatten v2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   117
  Stars vs -> concat (map flatten vs)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   118
  Rec _ v -> flatten v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   119
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   120
env :: Value -> [(String, String)]
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   121
env v = case v of 
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   122
  Empty -> []
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   123
  Chr c -> []
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   124
  Lf v -> env v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   125
  Rg v -> env v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   126
  Sequ v1 v2 -> env v1 ++ env v2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   127
  Stars vs -> foldl (++) [] (map env vs)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   128
  Rec x v -> (x, flatten v) : env v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   129
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   130
string_of_pair :: (String, String) -> String
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   131
string_of_pair (x, s) = "(" ++ x ++ "," ++ s ++ ")"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   132
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   133
string_of_env :: [(String, String)] -> String
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   134
string_of_env xs = intercalate "," (map string_of_pair xs)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   135
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   136
mkeps :: Rexp -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   137
mkeps r = case r of 
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   138
  ONE -> Empty
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   139
  ALT r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   140
      if nullable r1 then Lf (mkeps r1) else Rg (mkeps r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   141
  SEQ r1 r2 -> Sequ (mkeps r1) (mkeps r2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   142
  STAR r -> Stars []
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   143
  RECD x r -> Rec x (mkeps r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   144
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   145
inj :: Rexp -> Char -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   146
inj r c v = case (r, v) of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   147
  (STAR r, Sequ v1 (Stars vs)) -> Stars (inj r c v1 : vs)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   148
  (SEQ r1 r2, Sequ v1 v2) -> Sequ (inj r1 c v1) v2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   149
  (SEQ r1 r2, Lf (Sequ v1 v2)) -> Sequ (inj r1 c v1) v2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   150
  (SEQ r1 r2, Rg v2) -> Sequ (mkeps r1) (inj r2 c v2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   151
  (ALT r1 r2, Lf v1) -> Lf (inj r1 c v1)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   152
  (ALT r1 r2, Rg v2) -> Rg (inj r2 c v2)
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   153
  (CHAR d, Empty) -> Chr d 
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   154
  (RECD x r1, _) -> Rec x (inj r1 c v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   155
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   156
f_id :: Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   157
f_id v = v
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   158
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   159
f_right :: (Value -> Value) -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   160
f_right f = \v -> Rg (f v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   161
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   162
f_left :: (Value -> Value) -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   163
f_left f = \v -> Lf (f v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   164
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   165
f_alt :: (Value -> Value) -> (Value -> Value) -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   166
f_alt f1 f2 = \v -> case v of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   167
  Rg v -> Rg (f2 v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   168
  Lf v -> Lf (f1 v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   169
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   170
f_seq :: (Value -> Value) -> (Value -> Value) -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   171
f_seq f1 f2 = \v -> case v of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   172
  Sequ v1 v2 -> Sequ (f1 v1) (f2 v2)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   173
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   174
f_seq_void1 :: (Value -> Value) -> (Value -> Value) -> Value -> Value
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   175
f_seq_void1 f1 f2 = \v -> Sequ (f1 Empty) (f2 v)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   176
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   177
f_seq_void2 :: (Value -> Value) -> (Value -> Value) -> Value -> Value
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   178
f_seq_void2 f1 f2 = \v -> Sequ(f1 v) (f2 Empty)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   179
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   180
f_rec :: (Value -> Value) -> Value -> Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   181
f_rec f = \v -> case v of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   182
    Rec x v -> Rec x (f v)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   183
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   184
simp :: Rexp -> (Rexp, Value -> Value)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   185
simp r = case r of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   186
    ALT r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   187
      let (r1s, f1s) = simp r1  
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   188
          (r2s, f2s) = simp r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   189
      in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   190
        (case (r1s, r2s) of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   191
            (ZERO, _) -> (r2s, f_right f2s)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   192
            (_, ZERO) -> (r1s, f_left f1s)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   193
            (_, _)    -> if r1s == r2s then (r1s, f_left f1s)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   194
                         else (ALT r1s r2s, f_alt f1s f2s))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   195
    SEQ r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   196
      let (r1s, f1s) = simp r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   197
          (r2s, f2s) = simp r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   198
      in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   199
        (case (r1s, r2s) of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   200
          (ZERO, _)  -> (ZERO, f_right f2s)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   201
          (_, ZERO)  -> (ZERO, f_left f1s)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   202
          (ONE, _) -> (r2s, f_seq_void1 f1s f2s)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   203
          (_, ONE) -> (r1s, f_seq_void2 f1s f2s)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   204
          (_, _)     -> (SEQ r1s r2s, f_seq f1s f2s))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   205
    RECD x r1 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   206
      let (r1s, f1s) = simp r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   207
      in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   208
        (RECD x r1s, f_rec f1s)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   209
    r -> (r, f_id)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   210
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   211
der_simp :: Char -> Rexp -> (Rexp, Value -> Value)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   212
der_simp c r = case r of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   213
    ZERO -> (ZERO, f_id)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   214
    ONE -> (ZERO, f_id)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   215
    CHAR(d) -> ((if c == d then ONE else ZERO), f_id)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   216
    ALT r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   217
      let (r1d, f1d) = der_simp c r1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   218
          (r2d, f2d) = der_simp c r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   219
      in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   220
        (case (r1d, r2d) of 
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   221
          (ZERO, _) -> (r2d, f_right f2d)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   222
          (_, ZERO) -> (r1d, f_left f1d)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   223
          (_, _)    -> if r1d == r2d then (r1d, f_left f1d)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   224
                       else (ALT r1d r2d, f_alt f1d f2d))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   225
    SEQ r1 r2 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   226
      if nullable r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   227
      then 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   228
        let (r1d, f1d) = der_simp c r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   229
            (r2d, f2d) = der_simp c r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   230
            (r2s, f2s) = simp r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   231
        in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   232
          (case (r1d, r2s, r2d) of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   233
             (ZERO, _, _)  -> (r2d, f_right f2d)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   234
             (_, ZERO, _)  -> (r2d, f_right f2d)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   235
             (_, _, ZERO)  -> (SEQ r1d r2s, f_left (f_seq f1d f2s))
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   236
             (ONE, _, _) -> (ALT r2s r2d, f_alt (f_seq_void1 f1d f2s) f2d)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   237
             (_, ONE, _) -> (ALT r1d r2d, f_alt (f_seq_void2 f1d f2s) f2d)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   238
             (_, _, _)     -> (ALT (SEQ r1d r2s) r2d, f_alt (f_seq f1d f2s) f2d))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   239
      else 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   240
        let (r1d, f1d) = der_simp c r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   241
            (r2s, f2s) = simp r2 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   242
        in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   243
          (case (r1d, r2s) of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   244
             (ZERO, _)  -> (ZERO, f_id)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   245
             (_, ZERO)  -> (ZERO, f_id)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   246
             (ONE, _) -> (r2s, f_seq_void1 f1d f2s)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   247
             (_, ONE) -> (r1d, f_seq_void2 f1d f2s)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   248
             (_, _) -> (SEQ r1d r2s, f_seq f1d f2s))	  
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   249
    STAR r1 -> 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   250
      let (r1d, f1d) = der_simp c r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   251
      in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   252
        (case r1d of
156
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   253
           ZERO -> (ZERO, f_id)
6a43ea9305ba updated implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents: 3
diff changeset
   254
           ONE -> (STAR r1, f_seq_void1 f1d f_id)
3
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   255
           _ -> (SEQ r1d (STAR r1), f_seq f1d f_id))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   256
    RECD x r1 -> der_simp c r1 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   257
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   258
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   259
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   260
matcher :: Rexp -> String -> Bool
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   261
matcher r s = nullable (ders s r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   262
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   263
lex0 :: Rexp -> String -> Maybe Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   264
lex0 r s = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   265
  [] -> if (nullable r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   266
        then Just (mkeps r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   267
        else Nothing
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   268
  c:cs -> do res <- lex0 (der c r) cs
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   269
             return (inj r c res)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   270
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   271
lex_simp :: Rexp -> String -> Maybe Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   272
lex_simp r s = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   273
  [] -> if (nullable r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   274
        then Just (mkeps r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   275
        else Nothing
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   276
  c:cs -> let 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   277
            (r_simp, f_simp) = simp (der c r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   278
          in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   279
             do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   280
               res <- lex_simp r_simp cs
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   281
               return (inj r c (f_simp res))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   282
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   283
lex_simp2 :: Rexp -> String -> Maybe Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   284
lex_simp2 r s = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   285
  [] -> if (nullable r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   286
        then Just (mkeps r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   287
        else Nothing
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   288
  c:cs -> let 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   289
            (r_simp, f_simp) = der_simp c r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   290
          in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   291
             do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   292
               res <- lex_simp2 r_simp cs
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   293
               return (inj r c (f_simp res))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   294
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   295
lex_acc :: Rexp -> String -> (Value -> Value) -> Maybe Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   296
lex_acc r s f = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   297
  [] -> if (nullable r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   298
        then Just (f (mkeps r)) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   299
        else Nothing
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   300
  c:cs -> let 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   301
            (r_simp, f_simp) = simp (der c r)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   302
          in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   303
            lex_acc r_simp cs (\v -> f (inj r c (f_simp v)))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   304
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   305
lex_acc2 :: Rexp -> String -> (Value -> Value) -> Maybe Value
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   306
lex_acc2 r s f = case s of 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   307
  [] -> if (nullable r) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   308
        then Just (f (mkeps r)) 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   309
        else Nothing
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   310
  c:cs -> let 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   311
            (r_simp, f_simp) = der_simp c r
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   312
          in
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   313
            lex_acc2 r_simp cs (\v -> f (inj r c (f_simp v)))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   314
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   315
sym = alts (map CHAR "abcdefghijklmnopqrstuvwxyz")
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   316
digit = alts (map CHAR "0123456789")
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   317
idents =  sym ~~ STAR(sym \/ digit)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   318
nums = plus digit
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   319
keywords = alts (map str ["skip", "while", "do", "if", "then", "else", "read", "write", "true", "false"])
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   320
semicolon = str ";"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   321
ops = alts (map str [":=", "==", "-", "+", "*", "!=", "<", ">", "<=", ">=", "%", "/"])
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   322
whitespace = plus(str " " \/ str "\n" \/ str "\t")
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   323
rparen = str ")"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   324
lparen = str "("
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   325
begin_paren = str "{"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   326
end_paren = str "}"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   327
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   328
while_regs = STAR(("k" $$ keywords) \/
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   329
                  ("i" $$ idents) \/
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   330
                  ("o" $$ ops) \/ 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   331
                  ("n" $$ nums) \/ 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   332
                  ("s" $$ semicolon) \/ 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   333
                  ("p" $$ (lparen \/ rparen)) \/ 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   334
                  ("b" $$ (begin_paren \/ end_paren)) \/ 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   335
                  ("w" $$ whitespace))
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   336
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   337
prog2 = intercalate "\n" 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   338
  ["i := 2;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   339
   "max := 100;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   340
   "while i < max do {",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   341
   "  isprime := 1;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   342
   "  j := 2;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   343
   "  while (j * j) <= i + 1  do {",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   344
   "    if i % j == 0 then isprime := 0  else skip;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   345
   "    j := j + 1",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   346
   "  };",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   347
   " if isprime == 1 then write i else skip;",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   348
   " i := i + 1",
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   349
   "}"]
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   350
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   351
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   352
lexing_simp :: Int -> Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   353
lexing_simp n = case (lex_simp while_regs (string_repeat prog2 n)) of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   354
  Just result -> 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   355
  Nothing -> 0
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   356
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   357
step_simp :: Int -> IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   358
step_simp n = do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   359
           putStr (show n ++ ": ") 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   360
           time (lexing_simp n)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   361
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   362
lexing_simp2 :: Int -> Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   363
lexing_simp2 n = case (lex_simp2 while_regs (string_repeat prog2 n)) of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   364
  Just result -> 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   365
  Nothing -> 0
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   366
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   367
step_simp2 :: Int -> IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   368
step_simp2 n = do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   369
           putStr (show n ++ ": ") 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   370
           time (lexing_simp2 n)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   371
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   372
lexing_acc :: Int -> Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   373
lexing_acc n = case (lex_acc while_regs (string_repeat prog2 n) f_id) of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   374
  Just result -> 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   375
  Nothing -> 0
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   376
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   377
step_acc :: Int -> IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   378
step_acc n = do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   379
           putStr (show n ++ ": ") 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   380
           time (lexing_acc n)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   381
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   382
lexing_acc2 :: Int -> Int
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   383
lexing_acc2 n = case (lex_acc2 while_regs (string_repeat prog2 n) f_id) of
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   384
  Just result -> 1
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   385
  Nothing -> 0
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   386
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   387
step_acc2 :: Int -> IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   388
step_acc2 n = do 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   389
           putStr (show n ++ ": ") 
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   390
           time (lexing_acc2 n)
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   391
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   392
main :: IO ()
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   393
main = do
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   394
        forM_  [1000,2000..5000] step_simp
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   395
        printf "\n"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   396
        forM_  [1000,2000..5000] step_simp2
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   397
        printf "\n"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   398
        forM_  [1000,2000..5000] step_acc
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   399
        printf "\n"
94824659f6d7 added all toy implementations
Christian Urban <christian dot urban at kcl dot ac dot uk>
parents:
diff changeset
   400
        forM_  [1000,2000..5000] step_acc2