1 import System.Environment

     2 import Data.List

     3 import Text.Printf

     4 import Control.Exception

     5 import System.CPUTime

     6 import Control.Parallel.Strategies

     7 import Control.Monad

     8 

     9 lim :: Int

    10 lim = 1

    11 -- lim = 10^6

    12  

    13 time :: (Num t, NFData t) => t -> IO ()

    14 time y = do

    15     start <- getCPUTime

    16     replicateM_ lim $ do

    17         x <- evaluate $ 1 + y

    18         rdeepseq x `seq` return ()

    19     end   <- getCPUTime

    20     let diff = (fromIntegral (end - start)) / (10^12)

    21     printf "%0.9f\n" (diff :: Double)

    22     return ()

    23 

    24 data Rexp =

    25    NULL 

    26  | EMPTY 

    27  | CHAR Char

    28  | ALT Rexp Rexp

    29  | SEQ Rexp Rexp 

    30  | STAR Rexp 

    31  | RECD String Rexp deriving (Eq, Show) 

    32 

    33 data Value =

    34    Void

    35  | Chr Char

    36  | Sequ Value Value

    37  | Lf Value

    38  | Rg Value

    39  | Stars [Value]

    40  | Rec String Value deriving (Eq, Show) 

    41 

    42 string_repeat :: String -> Int -> String

    43 string_repeat s n = concat (replicate n s)

    44 

    45 sequ :: [Char] -> Rexp

    46 sequ s = case s of

    47   [] -> EMPTY

    48   [c] -> CHAR c

    49   c:cs -> SEQ (CHAR c) (sequ cs)

    50 

    51 

    52 str :: String -> Rexp

    53 str s = sequ s

    54 

    55 plus :: Rexp -> Rexp

    56 plus r = SEQ r (STAR r)

    57 

    58 (\/) :: Rexp -> Rexp -> Rexp 

    59 r1 \/ r2 = ALT r1 r2

    60 

    61 (~~) :: Rexp -> Rexp -> Rexp 

    62 r1 ~~ r2 = SEQ r1 r2

    63 

    64 ($$) :: String -> Rexp -> Rexp 

    65 x $$ r = RECD x r

    66 

    67 alts :: [Rexp] -> Rexp

    68 alts rs = case rs of

    69   [] -> NULL

    70   [r] -> r

    71   r:rs -> foldl (ALT) r rs

    72 

    73 size :: Rexp -> Int

    74 size r = case r of

    75   NULL -> 1

    76   EMPTY -> 1

    77   CHAR _ -> 1

    78   ALT r1 r2 -> 1 + (size r1) + (size r2)

    79   SEQ r1 r2 -> 1 + (size r1) + (size r2)

    80   STAR r -> 1 + (size r)

    81   RECD _ r -> 1 + (size r)

    82 

    83 nullable :: Rexp -> Bool

    84 nullable r = case r of

    85   NULL -> False

    86   EMPTY -> True

    87   CHAR _ -> False

    88   ALT r1 r2 -> nullable(r1) || nullable(r2)

    89   SEQ r1 r2 -> nullable(r1) && nullable(r2)

    90   STAR _ -> True

    91   RECD _ r -> nullable(r)

    92 

    93 der :: Char -> Rexp -> Rexp

    94 der c r = case r of

    95   NULL -> NULL

    96   EMPTY -> NULL

    97   CHAR d -> if c == d then EMPTY else NULL

    98   ALT r1 r2 -> ALT (der c r1) (der c r2)

    99   SEQ r1 r2 -> 

   100       if nullable r1 then ALT (SEQ (der c r1) r2) (der c r2)

   101       else SEQ (der c r1) r2

   102   STAR r -> SEQ (der c r) (STAR r)

   103   RECD _ r -> der c r

   104 

   105 ders :: [Char] -> Rexp -> Rexp

   106 ders s r = case s of 

   107   [] -> r

   108   c:s -> ders s (der c r)

   109 

   110 flatten :: Value -> String

   111 flatten v = case v of 

   112   Void -> ""

   113   Chr c -> [c]

   114   Lf v -> flatten v

   115   Rg v -> flatten v

   116   Sequ v1 v2 -> flatten v1 ++ flatten v2

   117   Stars vs -> concat (map flatten vs)

   118   Rec _ v -> flatten v

   119 

   120 env :: Value -> [(String, String)]

   121 env v = case v of 

   122   Void -> []

   123   Chr c -> []

   124   Lf v -> env v

   125   Rg v -> env v

   126   Sequ v1 v2 -> env v1 ++ env v2

   127   Stars vs -> foldl (++) [] (map env vs)

   128   Rec x v -> (x, flatten v) : env v

   129 

   130 string_of_pair :: (String, String) -> String

   131 string_of_pair (x, s) = "(" ++ x ++ "," ++ s ++ ")"

   132 

   133 string_of_env :: [(String, String)] -> String

   134 string_of_env xs = intercalate "," (map string_of_pair xs)

   135 

   136 mkeps :: Rexp -> Value

   137 mkeps r = case r of 

   138   EMPTY -> Void

   139   ALT r1 r2 -> 

   140       if nullable r1 then Lf (mkeps r1) else Rg (mkeps r2)

   141   SEQ r1 r2 -> Sequ (mkeps r1) (mkeps r2)

   142   STAR r -> Stars []

   143   RECD x r -> Rec x (mkeps r)

   144 

   145 inj :: Rexp -> Char -> Value -> Value

   146 inj r c v = case (r, v) of

   147   (STAR r, Sequ v1 (Stars vs)) -> Stars (inj r c v1 : vs)

   148   (SEQ r1 r2, Sequ v1 v2) -> Sequ (inj r1 c v1) v2

   149   (SEQ r1 r2, Lf (Sequ v1 v2)) -> Sequ (inj r1 c v1) v2

   150   (SEQ r1 r2, Rg v2) -> Sequ (mkeps r1) (inj r2 c v2)

   151   (ALT r1 r2, Lf v1) -> Lf (inj r1 c v1)

   152   (ALT r1 r2, Rg v2) -> Rg (inj r2 c v2)

   153   (CHAR d, Void) -> Chr d 

   154   (RECD x r1, _) -> Rec x (inj r1 c v)

   155 

   156 f_id :: Value -> Value

   157 f_id v = v

   158 

   159 f_right :: (Value -> Value) -> Value -> Value

   160 f_right f = \v -> Rg (f v)

   161 

   162 f_left :: (Value -> Value) -> Value -> Value

   163 f_left f = \v -> Lf (f v)

   164 

   165 f_alt :: (Value -> Value) -> (Value -> Value) -> Value -> Value

   166 f_alt f1 f2 = \v -> case v of

   167   Rg v -> Rg (f2 v)

   168   Lf v -> Lf (f1 v)

   169 

   170 f_seq :: (Value -> Value) -> (Value -> Value) -> Value -> Value

   171 f_seq f1 f2 = \v -> case v of 

   172   Sequ v1 v2 -> Sequ (f1 v1) (f2 v2)

   173 

   174 f_seq_void1 :: (Value -> Value) -> (Value -> Value) -> Value -> Value

   175 f_seq_void1 f1 f2 = \v -> Sequ (f1 Void) (f2 v)

   176 

   177 f_seq_void2 :: (Value -> Value) -> (Value -> Value) -> Value -> Value

   178 f_seq_void2 f1 f2 = \v -> Sequ(f1 v) (f2 Void)

   179 

   180 f_rec :: (Value -> Value) -> Value -> Value

   181 f_rec f = \v -> case v of

   182     Rec x v -> Rec x (f v)

   183 

   184 simp :: Rexp -> (Rexp, Value -> Value)

   185 simp r = case r of

   186     ALT r1 r2 -> 

   187       let (r1s, f1s) = simp r1  

   188           (r2s, f2s) = simp r2 

   189       in

   190         (case (r1s, r2s) of

   191             (NULL, _) -> (r2s, f_right f2s)

   192             (_, NULL) -> (r1s, f_left f1s)

   193             (_, _)    -> if r1s == r2s then (r1s, f_left f1s)

   194                          else (ALT r1s r2s, f_alt f1s f2s))

   195     SEQ r1 r2 -> 

   196       let (r1s, f1s) = simp r1 

   197           (r2s, f2s) = simp r2 

   198       in

   199         (case (r1s, r2s) of

   200           (NULL, _)  -> (NULL, f_right f2s)

   201           (_, NULL)  -> (NULL, f_left f1s)

   202           (EMPTY, _) -> (r2s, f_seq_void1 f1s f2s)

   203           (_, EMPTY) -> (r1s, f_seq_void2 f1s f2s)

   204           (_, _)     -> (SEQ r1s r2s, f_seq f1s f2s))

   205     RECD x r1 -> 

   206       let (r1s, f1s) = simp r1 

   207       in

   208         (RECD x r1s, f_rec f1s)

   209     r -> (r, f_id)

   210 

   211 der_simp :: Char -> Rexp -> (Rexp, Value -> Value)

   212 der_simp c r = case r of

   213     NULL -> (NULL, f_id)

   214     EMPTY -> (NULL, f_id)

   215     CHAR(d) -> ((if c == d then EMPTY else NULL), f_id)

   216     ALT r1 r2 -> 

   217       let (r1d, f1d) = der_simp c r1

   218           (r2d, f2d) = der_simp c r2 

   219       in

   220         (case (r1d, r2d) of 

   221           (NULL, _) -> (r2d, f_right f2d)

   222           (_, NULL) -> (r1d, f_left f1d)

   223           (_, _)    -> if r1d == r2d then (r1d, f_left f1d)

   224                        else (ALT r1d r2d, f_alt f1d f2d))

   225     SEQ r1 r2 -> 

   226       if nullable r1 

   227       then 

   228         let (r1d, f1d) = der_simp c r1 

   229             (r2d, f2d) = der_simp c r2 

   230             (r2s, f2s) = simp r2 

   231         in

   232           (case (r1d, r2s, r2d) of

   233              (NULL, _, _)  -> (r2d, f_right f2d)

   234              (_, NULL, _)  -> (r2d, f_right f2d)

   235              (_, _, NULL)  -> (SEQ r1d r2s, f_left (f_seq f1d f2s))

   236              (EMPTY, _, _) -> (ALT r2s r2d, f_alt (f_seq_void1 f1d f2s) f2d)

   237              (_, EMPTY, _) -> (ALT r1d r2d, f_alt (f_seq_void2 f1d f2s) f2d)

   238              (_, _, _)     -> (ALT (SEQ r1d r2s) r2d, f_alt (f_seq f1d f2s) f2d))

   239       else 

   240         let (r1d, f1d) = der_simp c r1 

   241             (r2s, f2s) = simp r2 

   242         in

   243           (case (r1d, r2s) of

   244              (NULL, _)  -> (NULL, f_id)

   245              (_, NULL)  -> (NULL, f_id)

   246              (EMPTY, _) -> (r2s, f_seq_void1 f1d f2s)

   247              (_, EMPTY) -> (r1d, f_seq_void2 f1d f2s)

   248              (_, _) -> (SEQ r1d r2s, f_seq f1d f2s))	  

   249     STAR r1 -> 

   250       let (r1d, f1d) = der_simp c r1 

   251       in

   252         (case r1d of

   253            NULL -> (NULL, f_id)

   254            EMPTY -> (STAR r1, f_seq_void1 f1d f_id)

   255            _ -> (SEQ r1d (STAR r1), f_seq f1d f_id))

   256     RECD x r1 -> der_simp c r1 

   257 

   258 

   259 

   260 matcher :: Rexp -> String -> Bool

   261 matcher r s = nullable (ders s r)

   262 

   263 lex0 :: Rexp -> String -> Maybe Value

   264 lex0 r s = case s of 

   265   [] -> if (nullable r) 

   266         then Just (mkeps r) 

   267         else Nothing

   268   c:cs -> do res <- lex0 (der c r) cs

   269              return (inj r c res)

   270 

   271 lex_simp :: Rexp -> String -> Maybe Value

   272 lex_simp r s = case s of 

   273   [] -> if (nullable r) 

   274         then Just (mkeps r) 

   275         else Nothing

   276   c:cs -> let 

   277             (r_simp, f_simp) = simp (der c r)

   278           in

   279              do 

   280                res <- lex_simp r_simp cs

   281                return (inj r c (f_simp res))

   282 

   283 lex_simp2 :: Rexp -> String -> Maybe Value

   284 lex_simp2 r s = case s of 

   285   [] -> if (nullable r) 

   286         then Just (mkeps r) 

   287         else Nothing

   288   c:cs -> let 

   289             (r_simp, f_simp) = der_simp c r

   290           in

   291              do 

   292                res <- lex_simp2 r_simp cs

   293                return (inj r c (f_simp res))

   294 

   295 lex_acc :: Rexp -> String -> (Value -> Value) -> Maybe Value

   296 lex_acc r s f = case s of 

   297   [] -> if (nullable r) 

   298         then Just (f (mkeps r)) 

   299         else Nothing

   300   c:cs -> let 

   301             (r_simp, f_simp) = simp (der c r)

   302           in

   303             lex_acc r_simp cs (\v -> f (inj r c (f_simp v)))

   304 

   305 lex_acc2 :: Rexp -> String -> (Value -> Value) -> Maybe Value

   306 lex_acc2 r s f = case s of 

   307   [] -> if (nullable r) 

   308         then Just (f (mkeps r)) 

   309         else Nothing

   310   c:cs -> let 

   311             (r_simp, f_simp) = der_simp c r

   312           in

   313             lex_acc2 r_simp cs (\v -> f (inj r c (f_simp v)))

   314 

   315 sym = alts (map CHAR "abcdefghijklmnopqrstuvwxyz")

   316 digit = alts (map CHAR "0123456789")

   317 idents =  sym ~~ STAR(sym \/ digit)

   318 nums = plus digit

   319 keywords = alts (map str ["skip", "while", "do", "if", "then", "else", "read", "write", "true", "false"])

   320 semicolon = str ";"

   321 ops = alts (map str [":=", "==", "-", "+", "*", "!=", "<", ">", "<=", ">=", "%", "/"])

   322 whitespace = plus(str " " \/ str "\n" \/ str "\t")

   323 rparen = str ")"

   324 lparen = str "("

   325 begin_paren = str "{"

   326 end_paren = str "}"

   327 

   328 while_regs = STAR(("k" $$ keywords) \/

   329                   ("i" $$ idents) \/

   330                   ("o" $$ ops) \/ 

   331                   ("n" $$ nums) \/ 

   332                   ("s" $$ semicolon) \/ 

   333                   ("p" $$ (lparen \/ rparen)) \/ 

   334                   ("b" $$ (begin_paren \/ end_paren)) \/ 

   335                   ("w" $$ whitespace))

   336 

   337 prog2 = intercalate "\n" 

   338   ["i := 2;",

   339    "max := 100;",

   340    "while i < max do {",

   341    "  isprime := 1;",

   342    "  j := 2;",

   343    "  while (j * j) <= i + 1  do {",

   344    "    if i % j == 0 then isprime := 0  else skip;",

   345    "    j := j + 1",

   346    "  };",

   347    " if isprime == 1 then write i else skip;",

   348    " i := i + 1",

   349    "}"]

   350 

   351 

   352 lexing_simp :: Int -> Int

   353 lexing_simp n = case (lex_simp while_regs (string_repeat prog2 n)) of

   354   Just result -> 1

   355   Nothing -> 0

   356 

   357 step_simp :: Int -> IO ()

   358 step_simp n = do 

   359            putStr (show n ++ ": ") 

   360            time (lexing_simp n)

   361 

   362 lexing_simp2 :: Int -> Int

   363 lexing_simp2 n = case (lex_simp2 while_regs (string_repeat prog2 n)) of

   364   Just result -> 1

   365   Nothing -> 0

   366 

   367 step_simp2 :: Int -> IO ()

   368 step_simp2 n = do 

   369            putStr (show n ++ ": ") 

   370            time (lexing_simp2 n)

   371 

   372 lexing_acc :: Int -> Int

   373 lexing_acc n = case (lex_acc while_regs (string_repeat prog2 n) f_id) of

   374   Just result -> 1

   375   Nothing -> 0

   376 

   377 step_acc :: Int -> IO ()

   378 step_acc n = do 

   379            putStr (show n ++ ": ") 

   380            time (lexing_acc n)

   381 

   382 lexing_acc2 :: Int -> Int

   383 lexing_acc2 n = case (lex_acc2 while_regs (string_repeat prog2 n) f_id) of

   384   Just result -> 1

   385   Nothing -> 0

   386 

   387 step_acc2 :: Int -> IO ()

   388 step_acc2 n = do 

   389            putStr (show n ++ ": ") 

   390            time (lexing_acc2 n)

   391 

   392 main :: IO ()

   393 main = do

   394         forM_  [1000,2000..5000] step_simp

   395         printf "\n"

   396         forM_  [1000,2000..5000] step_simp2

   397         printf "\n"

   398         forM_  [1000,2000..5000] step_acc

   399         printf "\n"

   400         forM_  [1000,2000..5000] step_acc2