open Char;; open Printf;; open List;; exception Error of string;; type token = TId of string | TPlus | TMinus | TTimes | TLP | TRP | TEOF type parseTree = PE of parseTree * parseTree (* E -> T R *) | PR1 of parseTree * parseTree * parseTree (* R -> + T R *) | PR2 of parseTree * parseTree * parseTree (* R -> - T R *) | PR3 of parseTree (* R -> eps *) | PT of parseTree * parseTree (* T -> F S *) | PS1 of parseTree * parseTree * parseTree (* S -> * F S *) | PS2 of parseTree (* S -> eps *) | PF1 of parseTree (* F -> id *) | PF2 of parseTree * parseTree * parseTree (* F -> ( E ) *) | PEps | PPlus | PMinus | PTimes | PId of string | PLP | PRP type syntaxTree = SId of string (* Identifikator *) | SPlus of syntaxTree * syntaxTree (* Knoten für + *) | SMinus of syntaxTree * syntaxTree (* Knoten für - *) | STimes of syntaxTree * syntaxTree (* Knoten für * *) let id x = x;; let rec mkstUp ptree = match ptree with PE (t,r) -> mkstDown r (mkstUp t) | PT (f,s) -> mkstDown s (mkstUp f) | PF1 (PId s) -> SId s | PF2 (_,e,_) -> mkstUp e and mkstDown ptree fromLeft = match ptree with PR1 (_,t,r) -> mkstDown r (SPlus (fromLeft, mkstUp t)) | PR2 (_,t,r) -> mkstDown r (SMinus (fromLeft, mkstUp t)) | PR3 _ -> fromLeft | PS1 (_,s,f) -> mkstDown f (STimes (fromLeft, mkstUp s)) | PS2 _ -> fromLeft ;; let rec parseE' toks = let (e,rest) = parseE toks in match rest with [TEOF] -> e | _ -> raise (Error "EOF expected") and parseE rest = match hd rest with TId _ | TLP -> let (t,rest1) = parseT rest in let (r,rest2) = parseR rest1 in (PE (t,r), rest2) | _ -> raise (Error "E") and parseR rest = match hd rest with TPlus | TMinus -> let (t,rest1) = parseT (tl rest) in let (r,rest2) = parseR rest1 in begin match hd rest with TPlus -> (PR1 (PPlus,t,r), rest2) | TMinus -> (PR2 (PMinus,t,r), rest2) end | TRP | TEOF -> (PR3 PEps, rest) | _ -> raise (Error "R") and parseT rest = match hd rest with TId _ | TLP -> let (f,rest1) = parseF rest in let (s,rest2) = parseS rest1 in (PT (f,s), rest2) | _ -> raise (Error "T") and parseS rest = match hd rest with TTimes -> let (f,rest1) = parseF (tl rest) in let (s,rest2) = parseS rest1 in (PS1 (PTimes,f,s), rest2) | TPlus | TMinus | TRP | TEOF -> (PS2 PEps, rest) | _ -> raise (Error "S") and parseF rest = match hd rest with TId s -> (PF1 (PId s), tl rest) | TLP -> let (e,rest1) = parseE (tl rest) in begin match hd rest1 with TRP -> (PF2 (PLP,e,PRP), tl rest1) | _ -> raise (Error ") expected") end | _ -> raise (Error "F") ;; let isDigit x = code x >= code '0' && code x <= code '9';; let isAlpha x = (code x >= code 'a' && code x <= code 'z') || (code x >= code 'A' && code x <= code 'Z');; let explode s = let l = ref [] in for i=String.length s -1 downto 0 do l := (String.get s i) :: !l done; !l;; let implode cs = let xs = ref cs in let str = String.create (List.length cs) in for i=0 to String.length str -1 do let p::ps = !xs in String.set str i p; xs := ps done; str;; let rec scanWhile pred str = match str with | (x::xs) when pred x -> let (tok,rest) = scanWhile pred xs in (x::tok, rest) | _ -> ([],str) ;; let rec scan str = match str with | (x::xs) when isAlpha x -> let (cs,rest) = scanWhile isAlpha str in TId (implode cs) :: scan rest | ('+'::rest) -> TPlus :: scan rest | ('-'::rest) -> TMinus :: scan rest | ('*'::rest) -> TTimes :: scan rest | ('('::rest) -> TLP :: scan rest | (')'::rest) -> TRP :: scan rest | (' '::rest) -> scan rest | ('\t'::rest) -> scan rest | ('\n'::rest) -> scan rest | [] -> [TEOF] ;; let parseTree x = parseE' (scan (explode x));; let synTree x = mkstUp (parseTree x)