chiark - git - mdw - fringe/blob - f#-fringe.fs

   1 /// -*- mode: fsharp-mode; indent-tabs-mode: nil -*-
   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 -> Option.isNone(next itb)
  45     | Some (a, ita) ->
  46       match next itb with
  47         | Some (b, itb) when a = b -> same_iterators_p ita itb
  48         | _ -> false
  49
  50 ///--------------------------------------------------------------------------
  51 /// Nodes and trees.
  52
  53 // A simple type for binary tree nodes.
  54 type 'a node =
  55   | Leaf
  56   | Node of 'a node * 'a * 'a node
  57
  58 // Parse a tree from a description in STRING.  The syntax is:
  59 //
  60 //      tree ::= empty | `(' tree char tree `)'
  61 //
  62 // disambiguated by deciding that `(' starts a tree wherever a tree is
  63 // expected.  Not ever-so pretty; parser combinator version left as an
  64 // exercise.
  65 let parse_tree string =
  66   let n = String.length string
  67   let rec parse i =
  68     match i with
  69       | i when i < n && string.[i] = '(' ->
  70         let left, i = parse (i + 1)
  71         if i >= n then failwith "no data"
  72         let data = string.[i]
  73         let right, i = parse (i + 1)
  74         if i >= n || string.[i] <> ')' then failwith "missing )"
  75         Node (left, data, right), i + 1
  76       | _ -> Leaf, i
  77   let tree, i = parse 0
  78   if i < n then failwith "trailing junk"
  79   tree
  80
  81 // Return an iterator for the elements of T in order.
  82 let iterate_fringe t =
  83   let rec itfn t tail =
  84     match t with
  85       | Leaf -> tail ()
  86       | Node (l, ch, r) ->
  87         itfn l <| fun () -> Some (ch, Iter <| fun () -> itfn r tail)
  88   Iter <| fun () -> itfn t <| fun () -> None
  89
  90 ///--------------------------------------------------------------------------
  91 /// Main program.
  92
  93 let program_name = (System.Environment.GetCommandLineArgs ()).[0]
  94
  95 [<EntryPoint>]
  96 let main args =
  97   let run = function
  98     | [| a |] ->
  99       a |> parse_tree
 100         |> iterate_fringe
 101         |> fold_iterator (fun ch _ -> stdout.Write(ch)) ()
 102       stdout.Write('\n')
 103     | [| a; b |] ->
 104       if same_iterators_p
 105            (a |> parse_tree |> iterate_fringe)
 106            (b |> parse_tree |> iterate_fringe)
 107       then stdout.WriteLine("match")
 108       else stdout.WriteLine("no match")
 109     | _ -> failwith "bad args"
 110   try
 111     run args
 112     0
 113   with
 114     | exc ->
 115       fprintf stderr "%s: %s\n" program_name exc.Message
 116       1
 117
 118 ///----- That's all, folks --------------------------------------------------