ref: a9ac58af31c1f793739da9ac9182438b107f184a
dir: /Tools/Uncomb.hs/
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Uncomb where
import Data.Char
import Data.Data(Data)
import Data.Generics.Uniplate.Data
infix :@
data Exp
= S | S' | K | A | U | I | Y | B | B' | Z | C | C' | P | R | O | K2 | K3 | K4 | C'B
| Add | Sub | Lt
| Exp :@ Exp | Int Integer | Label Int Exp | Ref Int | Tick String | Vx
deriving (Show, Read, Data, Eq, Ord)
reduce :: Exp -> Exp
reduce (((S :@ x) :@ y) :@ z) = (x :@ z) :@ (y :@ z)
reduce ((((S' :@ x) :@ y) :@ z) :@ w) = (x :@ (y :@ w)) :@ (z :@ w)
reduce ((K :@ x) :@ _y) = x
reduce ((A :@ _x) :@ y) = y
reduce ((U :@ x) :@ y) = y :@ x
reduce (I :@ x) = x
reduce (((B :@ x) :@ y) :@ z) = x :@ (y :@ z)
reduce ((((B' :@ x) :@ y) :@ z) :@ w) = (x :@ y) :@ (z :@ w)
reduce (((Z :@ x) :@ y) :@ _z) = (x :@ y)
reduce (((C :@ x) :@ y) :@ z) = (x :@ z) :@ y
reduce ((((C' :@ x) :@ y) :@ z) :@ w) = (x :@ (y :@ w)) :@ z
reduce (((P :@ x) :@ y) :@ z) = (z :@ x) :@ y
reduce (((R :@ x) :@ y) :@ z) = (y :@ z) :@ x
reduce ((((O :@ x) :@ y) :@ z) :@ w) = (w :@ x) :@ y
reduce (((K2 :@ x) :@ _y) :@ _z) = x
reduce ((((K3 :@ x) :@ _y) :@ _z) :@ _w) = x
reduce (((((K4 :@ x) :@ _y) :@ _z) :@ _w) :@ _v) = x
reduce ((((C'B :@ x) :@ y) :@ z) :@ w) = (x :@ z) :@ (y :@ w)
reduce (Label _ e) = e
reduce (Tick _ :@ e) = e
reduce e = e
parseExp :: String -> (Exp, String)
parseExp (' ':cs) = parseExp cs
parseExp ('(':cs) = (e1 :@ e2, r'')
where (e1, r) = parseExp cs
(e2, r') = parseExp r
r'' = case r' of (')':s) -> s; _ -> error ")"
parseExp ('#':cs) = (Int (read n), r) where (n, r) = span isDigit cs
parseExp (':':cs) = (Label (read n) e, r') where (n, r) = span isDigit cs; (e, r') = parseExp r
parseExp ('_':cs) = (Ref (read n), r) where (n, r) = span isDigit cs
parseExp ('!':'"':cs) = (Tick (init n), drop 1 r) where (n, r) = span (/= '"') cs
parseExp ('+':cs) = (Add, cs)
parseExp ('-':cs) = (Sub, cs)
parseExp ('<':cs) = (Lt, cs)
parseExp ('C':'\'':'B':cs) = (C'B, cs)
parseExp ('S':'\'':cs) = (S', cs)
parseExp ('C':'\'':cs) = (C', cs)
parseExp ('B':'\'':cs) = (B', cs)
parseExp ('K':'2':cs) = (K2, cs)
parseExp ('K':'3':cs) = (K3, cs)
parseExp ('K':'4':cs) = (K4, cs)
parseExp ('S':cs) = (S, cs)
parseExp ('K':cs) = (K, cs)
parseExp ('A':cs) = (A, cs)
parseExp ('U':cs) = (U, cs)
parseExp ('I':cs) = (I, cs)
parseExp ('Y':cs) = (Y, cs)
parseExp ('B':cs) = (B, cs)
parseExp ('Z':cs) = (Z, cs)
parseExp ('C':cs) = (C, cs)
parseExp ('P':cs) = (P, cs)
parseExp ('R':cs) = (R, cs)
parseExp ('O':cs) = (O, cs)
parseExp ('x':cs) = (Vx, cs)
parseExp cs = error $ "parseExp: " ++ show (take 20 cs)
readExp :: String -> Exp
readExp s =
case parseExp s of
(e, "") -> e
x -> error $ "readExp: " ++ show x
red :: Exp -> Exp
red = transform reduce
s1 = "(U (K ((B C) (P #111))))"
t1 = readExp s1
s2 = "((C ((C (U ((C'B (B' P)) ((B (C' C)) (C P))))) A)) #111)"
t2 = readExp s2
s3 = "((C B) (C (U (K2 A))))"
t3 = readExp s3
s4 = "(:942 ((C ((S ((C <) #2)) (((C' +) (((S' +) ((B :491 ((B !\"F.nfib\") _942)) :4157 ((C -) #1))) ((B _491) ((C -) #2)))) #1))) #1) (_4157 #3))"
t4 = readExp s4
s5 = "(:942 ((C ((S ((C <) #2)) (((C' +) (((S' +) ((B :491 ((B !\"F.nfib\") _942)) :4157 ((C -) #1))) ((B _491) ((C -) #2)))) #1))) #1) x)"
t5 = readExp s5