| 1 | /// -*-f#-mode-*- |
| 2 | /// |
| 3 | /// F# implementation of a `same-fringe' solver. |
| 4 | |
| 5 | module Fringe |
| 6 | |
| 7 | ///-------------------------------------------------------------------------- |
| 8 | /// Utilities. |
| 9 | |
| 10 | let curry f x y = f (x, y) |
| 11 | let uncurry f (x, y) = f x y |
| 12 | |
| 13 | ///-------------------------------------------------------------------------- |
| 14 | /// Iteration machinery. |
| 15 | |
| 16 | // The type of an iterator. Unfortunately we need a layer of boxing to stop |
| 17 | // the compiler being unappy about infinite types. Silly compiler. |
| 18 | type 'a iterator = Iter of (unit -> ('a * 'a iterator) option) |
| 19 | |
| 20 | // A handy way of getting to the actual iterator function. |
| 21 | let next (Iter itfn) = itfn () |
| 22 | |
| 23 | // Return an iterator for the items in the list XS. |
| 24 | let rec iterate_list xs = |
| 25 | let itfn = match xs with |
| 26 | | [] -> fun () -> None |
| 27 | | x::xs -> fun () -> Some (x, iterate_list xs) |
| 28 | Iter itfn |
| 29 | |
| 30 | // For each item X returned by the iterator, update the state A as F X A; |
| 31 | // return the final state. |
| 32 | let fold_iterator f a it = |
| 33 | let rec recur = function |
| 34 | | a, None -> a |
| 35 | | a, Some (x, it) -> recur (f x a, next it) |
| 36 | recur (a, next it) |
| 37 | |
| 38 | // Return a list containing the items returned by the iterator IT. |
| 39 | let list_iterator it = it |> fold_iterator (curry List.Cons) [] |> List.rev |
| 40 | |
| 41 | // Asnwer whether two iterators report the same items. |
| 42 | let rec same_iterators_p ita itb = |
| 43 | match next ita with |
| 44 | | None -> |
| 45 | match next itb with |
| 46 | | None -> true |
| 47 | | _ -> false |
| 48 | | Some (a, ita) -> |
| 49 | match next itb with |
| 50 | | None -> false |
| 51 | | Some (b, itb) -> |
| 52 | if a = b then same_iterators_p ita itb |
| 53 | else false |
| 54 | |
| 55 | ///-------------------------------------------------------------------------- |
| 56 | /// Nodes and trees. |
| 57 | |
| 58 | // A simple type for binary tree nodes. |
| 59 | type 'a node = |
| 60 | | Leaf |
| 61 | | Node of 'a node * 'a * 'a node |
| 62 | |
| 63 | // Parse a tree from a description in STRING. The syntax is: |
| 64 | // |
| 65 | // tree ::= empty | `(' tree char tree `)' |
| 66 | // |
| 67 | // disambiguated by deciding that `(' starts a tree wherever a tree is |
| 68 | // expected. Not ever-so pretty; parser combinator version left as an |
| 69 | // exercise. |
| 70 | let parse_tree string = |
| 71 | let n = String.length string |
| 72 | let rec parse i = |
| 73 | match i with |
| 74 | | i when i < n && string.[i] = '(' -> |
| 75 | let left, i = parse (i + 1) |
| 76 | if i >= n then failwith "no data" |
| 77 | let data = string.[i] |
| 78 | let right, i = parse (i + 1) |
| 79 | if i >= n || string.[i] <> ')' then failwith "missing )" |
| 80 | Node (left, data, right), i + 1 |
| 81 | | _ -> Leaf, i |
| 82 | let tree, i = parse 0 |
| 83 | if i < n then failwith "trailing junk" |
| 84 | tree |
| 85 | |
| 86 | // Return an iterator for the elements of T in order. |
| 87 | let iterate_fringe t = |
| 88 | let rec itfn t tail = |
| 89 | match t with |
| 90 | | Leaf -> tail () |
| 91 | | Node (l, ch, r) -> |
| 92 | itfn l <| fun () -> Some (ch, Iter <| fun () -> itfn r tail) |
| 93 | Iter <| fun () -> itfn t <| fun () -> None |
| 94 | |
| 95 | ///-------------------------------------------------------------------------- |
| 96 | /// Main program. |
| 97 | |
| 98 | let program_name = (System.Environment.GetCommandLineArgs ()).[0] |
| 99 | |
| 100 | [<EntryPoint>] |
| 101 | let main args = |
| 102 | let run = function |
| 103 | | [| a |] -> |
| 104 | a |> parse_tree |
| 105 | |> iterate_fringe |
| 106 | |> fold_iterator (fun ch _ -> stdout.Write(ch)) () |
| 107 | stdout.Write('\n') |
| 108 | | [| a; b |] -> |
| 109 | if same_iterators_p |
| 110 | (a |> parse_tree |> iterate_fringe) |
| 111 | (b |> parse_tree |> iterate_fringe) |
| 112 | then stdout.WriteLine("match") |
| 113 | else stdout.WriteLine("no match") |
| 114 | | _ -> failwith "bad args" |
| 115 | try |
| 116 | run args |
| 117 | 0 |
| 118 | with |
| 119 | | exc -> |
| 120 | fprintf stderr "%s: %s\n" program_name exc.Message |
| 121 | 1 |
| 122 | |
| 123 | ///----- That's all, folks -------------------------------------------------- |