--- /dev/null
+*~
+#*
+test.log
+*.im
+*.o
+*.exe
+*.hi
+*-fringe
--- /dev/null
+### Makefile for same-fringe implementations.
+
+###--------------------------------------------------------------------------
+### Notes about organization.
+###
+### Most projects have lots of stuff in just a few languages, so it makes
+### sense to put the language configuration in one place. This one's
+### different. Its entire purpose is to demonstrate lots of different
+### approaches.
+###
+### So, at the top we declare the main targets; then each language has its
+### configuration and build rules.
+
+.SUFFIXES: .o
+LANGS =
+TARGETS = $(patsubst %,%-fringe,$(LANGS))
+CLEANFILES = $(TARGETS)
+
+all::
+clean::; rm -f $(CLEANFILES)
+
+###--------------------------------------------------------------------------
+### Testing.
+
+CLEANFILES += test.*
+test:: all
+ @win=0 lose=0; \
+ for lang in $(LANGS); do \
+ echo >&3 "*** $$lang"; \
+ printf "Test $$lang..."; \
+ if ./test ./$${lang}-fringe 2>&3; then \
+ win=$$(expr $$win + 1); \
+ printf " ok\n"; \
+ else \
+ lose=$$(expr $$lose + 1); \
+ printf " FAILED\n"; \
+ fi; \
+ done 3>test.log; \
+ if [ $$lose -eq 0 ]; then \
+ echo "All $$win test(s) OK"; \
+ else \
+ echo "FAILED $$lose test(s)!"; \
+ exit 1; \
+ fi
+
+###--------------------------------------------------------------------------
+### C.
+
+CC = gcc
+CFLAGS = -O2 -g -pedantic -Wall
+CLEANFILES += *.o
+.SUFFIXES: .c
+.c.o:; $(CC) -c $(CFLAGS) -o $@ $<
+
+LANGS += c
+c-fringe: c-fringe.o
+ $(CC) -o $@ $^
+
+###--------------------------------------------------------------------------
+### Haskell.
+
+HC = ghc
+HFLAGS = -O2 -XFlexibleInstances
+CLEANFILES += *.hi *.hc
+.SUFFIXES: .hs
+.hs.o:; $(HC) -c $(HFLAGS) -o $@ $<
+
+LANGS += haskell
+haskell-fringe: haskell-fringe.o
+ $(HC) -o $@ $^
+
+###--------------------------------------------------------------------------
+### Icon.
+
+ICONT = icont
+IFLAGS = -u -fa
+
+LANGS += icon
+icon-fringe: icon-fringe.icn
+ $(ICONT) -o $@ $^
+
+###--------------------------------------------------------------------------
+### Common Lisp.
+
+LANGS += cl
+cl-fringe: cl-fringe.lisp
+ cl-launch -R -o $@ -f `pwd`/$^
+
+###--------------------------------------------------------------------------
+### F#.
+
+FSC = fsc
+CLEANFILES += *.exe
+.SUFFIXES: .fs .exe
+.fs.exe:; fsc -o $@ $<
+
+LANGS += f\#
+f\#-fringe: f\#-fringe.exe
+ chmod +x $<
+ cp $< $@
+
+###--------------------------------------------------------------------------
+### Scheme.
+
+SCMC = csc
+SCMFLAGS = -c -O2
+.SUFFIXES: .scm .o
+.scm.o:; $(SCMC) $(SCMFLAGS) -o $@ $<
+
+LANGS += scheme
+scheme-fringe: scheme-fringe.o
+ $(SCMC) -o $@ $^
+
+###--------------------------------------------------------------------------
+### Smalltalk.
+
+LANGS += smalltalk
+TARGETS += smalltalk-fringe.im
+smalltalk-fringe.im: smalltalk-fringe.st
+ echo "ObjectMemory snapshot: '$@.new'" | gst $^ -
+ mv $@.new $@
+smalltalk-fringe:
+ { echo '#! /bin/sh'; \
+ echo '"exec" "gst" "-I" "$@.im" "-f" "$$0" "$$@"'; \
+ echo 'ObjectMemory quit: (Node main: Smalltalk arguments)'; \
+ } >$@.new
+ chmod +x $@.new
+ mv $@.new $@
+
+###----- That's all, folks --------------------------------------------------
+
+all:: $(TARGETS)
--- /dev/null
+/* -*-c-*-
+ *
+ * Prosaic C implementation of a `same-fringe' solver.
+ */
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+/*----- Utilities ---------------------------------------------------------*/
+
+static const char *progname = "?";
+
+/* Mournfully announce an error and quit. */
+static void bail(const char *m)
+ { fprintf(stderr, "%s: %s\n", progname, m); exit(EXIT_FAILURE); }
+
+/*----- Our node structure ------------------------------------------------*/
+
+struct node {
+ struct node *left;
+ struct node *right;
+ int data;
+};
+
+/* Make a new node and return it. */
+static struct node *makenode(int data, struct node *left, struct node *right)
+{
+ struct node *n = malloc(sizeof(*n));
+
+ if (!n) bail("no memory");
+ n->data = data; n->left = left; n->right = right;
+ return (n);
+}
+
+/* Free node N and its subtrees. */
+static void freetree(struct node *n)
+ { if (n) { freetree(n->left); freetree(n->right); free(n); } }
+
+/* Recursive parser, used by `parsetree': read from string, updating `*p' as
+ * we go.
+ */
+static struct node *rparsetree(const char **p)
+{
+ struct node *left, *right;
+ int data;
+
+ switch (**p) {
+ case '(':
+ (*p)++;
+ left = rparsetree(p);
+ data = *(*p)++;
+ if (!data) bail("no data");
+ right = rparsetree(p);
+ if (**p != ')') bail("missing )");
+ (*p)++;
+ return (makenode(data, left, right));
+ default:
+ return (0);
+ }
+}
+
+/* Parse a tree description from the string `p'.
+ *
+ * The syntax is as follows.
+ *
+ * tree ::= empty | `(' tree char tree `)'
+ *
+ * where the ambiguity is resolved by always treating `(' as starting a tree
+ * if a tree is expected.
+ */
+static struct node *parsetree(const char *p)
+{
+ struct node *n = rparsetree(&p);
+
+ if (*p) bail("trailing junk");
+ return (n);
+}
+
+/*----- Iteration ---------------------------------------------------------*/
+
+struct nodeiter {
+#define MAXDEPTH 64
+ struct node *stack[MAXDEPTH];
+ int sp;
+};
+
+/* Helper for `nextnode' and `iternodes'. If N is not null, push it onto
+ * NI's stack, and then do the same for N's left child.
+ */
+static void pushnodes(struct nodeiter *ni, struct node *n)
+{
+ int sp = ni->sp;
+
+ while (n) {
+ assert(sp < MAXDEPTH);
+ ni->stack[sp++] = n;
+ n = n->left;
+ }
+ ni->sp = sp;
+}
+
+/* Return the next node in order for the tree being traversed by NI, or null
+ * if all nodes are exhausted.
+ */
+static struct node *nextnode(struct nodeiter *ni)
+{
+ struct node *n;
+
+ if (!ni->sp)
+ return (0);
+ else {
+ n = ni->stack[--ni->sp];
+ pushnodes(ni, n->right);
+ return (n);
+ }
+}
+
+/* Initialize NI as an iterator iterating over the tree headed by N. */
+static void iternodes(struct nodeiter *ni, struct node *n)
+ { ni->sp = 0; pushnodes(ni, n); }
+
+/*------ Fringe operations ------------------------------------------------*/
+
+/* Print the characters stored in the tree headed by N to stdout, in
+ * order. */
+static void printfringe(struct node *n)
+{
+ struct nodeiter ni;
+
+ for (iternodes(&ni, n); (n = nextnode(&ni)) != 0; )
+ putchar(n->data);
+ putchar('\n');
+}
+
+/* Return nonzero if traversing the trees headed by N and NN respectively
+ * yields the same items in the same order.
+ */
+static int samefringep(struct node *n, struct node *nn)
+{
+ struct nodeiter ni, nni;
+
+ iternodes(&ni, n); iternodes(&nni, nn);
+ for (;;) {
+ n = nextnode(&ni); nn = nextnode(&nni);
+ if (!n) return (!nn);
+ else if (!nn) return (0);
+ else if (n->data != nn->data) return (0);
+ }
+}
+
+/*----- Main program ------------------------------------------------------*/
+
+int main(int argc, char *argv[])
+{
+ struct node *n, *nn;
+
+ progname = argv[0];
+ switch (argc) {
+ case 2:
+ n = parsetree(argv[1]);
+ printfringe(n);
+ freetree(n);
+ break;
+ case 3:
+ n = parsetree(argv[1]); nn = parsetree(argv[2]);
+ printf("%s\n", samefringep(n, nn) ? "match" : "no match");
+ freetree(n); freetree(nn);
+ break;
+ default:
+ bail("bad args");
+ break;
+ }
+ return (0);
+}
+
+/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Lisp implementation of a `same-fringe' solver.
+
+;;;--------------------------------------------------------------------------
+;;; Iteration utilities.
+
+;; The iteration protocol is as follows. An iterator is simply a function
+;; invoked with no arguments. It returns two values: the next item, and a
+;; new iterator function to produce the remaining items; if there are no more
+;; items, then it returns NIL twice.
+
+(defun list-iterator (iter)
+ "Collect the items from ITER into a list and return it."
+ (labels ((recur (iter list)
+ (multiple-value-bind (data iter) (funcall iter)
+ (if iter
+ (recur iter (cons data list))
+ (nreverse list)))))
+ (recur iter nil)))
+
+(defun same-iterators-p (iter-a iter-b &key (test #'eql))
+ "Return whether ITER-A and ITER-B produce the same items."
+ (labels ((recur (iter-a iter-b)
+ (multiple-value-bind (data-a iter-a) (funcall iter-a)
+ (multiple-value-bind (data-b iter-b) (funcall iter-b)
+ (cond ((null iter-a) (null iter-b))
+ ((or (null iter-b)
+ (not (funcall test data-a data-b)))
+ nil)
+ (t (recur iter-a iter-b)))))))
+ (recur iter-a iter-b)))
+
+;;;--------------------------------------------------------------------------
+;;; Nodes and trees.
+
+(defstruct node
+ "A simple node in a binary tree. Empty subtrees are denoted by NIL."
+ left data right)
+
+(defun iterate-fringe (node)
+ "Inorder iterator for the tree headed by NODE."
+ (labels ((recur (node cont)
+ (cond (node (recur (node-left node)
+ (lambda ()
+ (values (node-data node)
+ (lambda ()
+ (recur (node-right node)
+ cont))))))
+ (cont (funcall cont))
+ (t (values nil nil)))))
+ (lambda () (recur node nil))))
+
+(defun parse-tree (string)
+ "Parse STRING, and return the tree described.
+
+ The syntax is simple:
+
+ tree ::= empty | `(' tree char tree `)'
+
+ The ambiguity is resolved by always treating `(' as a tree when a tree is
+ expected."
+
+ (let ((len (length string)))
+ (labels ((parse (i)
+ (cond ((>= i len)
+ (values nil i))
+ ((char= (char string i) #\()
+ (multiple-value-bind (left i) (parse (1+ i))
+ (unless (< i len) (error "no data"))
+ (let ((data (char string i)))
+ (multiple-value-bind (right i) (parse (1+ i))
+ (unless (and (< i len)
+ (char= (char string i) #\)))
+ (error "missing )"))
+ (values
+ (make-node :left left :data data :right right)
+ (1+ i))))))
+ (t (values nil i)))))
+ (multiple-value-bind (tree i) (parse 0)
+ (unless (= i len) (error "trailing junk"))
+ tree))))
+
+;;;--------------------------------------------------------------------------
+;;; Main program.
+
+(defun main (args)
+ "Main program: process ARGS."
+ (destructuring-bind (&optional a b &rest junk) args
+ (cond ((or (null a) junk) (error "bad args"))
+ ((null b) (format t "~{~C~}~%"
+ (list-iterator (iterate-fringe (parse-tree a)))))
+ (t (format t "~:[no match~;match~]~%"
+ (same-iterators-p (iterate-fringe (parse-tree a))
+ (iterate-fringe (parse-tree b))))))))
+
+#+cl-launch
+(flet ((bail (format args)
+ (format *error-output* "~A: ~?~%"
+ (cl-launch:getenv "CL_LAUNCH_FILE") format args)
+ (cl-launch:quit 1)))
+ (handler-case
+ (main cl-launch:*arguments*)
+ (simple-error (err)
+ (bail (simple-condition-format-control err)
+ (simple-condition-format-arguments err)))
+ (error (err)
+ (bail "~A" err))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+/// -*-f#-mode-*-
+///
+/// F# implementation of a `same-fringe' solver.
+
+module Fringe
+
+///--------------------------------------------------------------------------
+/// Utilities.
+
+let curry f x y = f (x, y)
+let uncurry f (x, y) = f x y
+
+///--------------------------------------------------------------------------
+/// Iteration machinery.
+
+// The type of an iterator. Unfortunately we need a layer of boxing to stop
+// the compiler being unappy about infinite types. Silly compiler.
+type 'a iterator = Iter of (unit -> ('a * 'a iterator) option)
+
+// A handy way of getting to the actual iterator function.
+let next (Iter itfn) = itfn ()
+
+// Return an iterator for the items in the list XS.
+let rec iterate_list xs =
+ let itfn = match xs with
+ | [] -> fun () -> None
+ | x::xs -> fun () -> Some (x, iterate_list xs)
+ Iter itfn
+
+// For each item X returned by the iterator, update the state A as F X A;
+// return the final state.
+let fold_iterator f a it =
+ let rec recur = function
+ | a, None -> a
+ | a, Some (x, it) -> recur (f x a, next it)
+ recur (a, next it)
+
+// Return a list containing the items returned by the iterator IT.
+let list_iterator it = it |> fold_iterator (curry List.Cons) [] |> List.rev
+
+// Asnwer whether two iterators report the same items.
+let rec same_iterators_p ita itb =
+ match next ita with
+ | None ->
+ match next itb with
+ | None -> true
+ | _ -> false
+ | Some (a, ita) ->
+ match next itb with
+ | None -> false
+ | Some (b, itb) ->
+ if a = b then same_iterators_p ita itb
+ else false
+
+///--------------------------------------------------------------------------
+/// Nodes and trees.
+
+// A simple type for binary tree nodes.
+type 'a node =
+ | Leaf
+ | Node of 'a node * 'a * 'a node
+
+// Parse a tree from a description in STRING. The syntax is:
+//
+// tree ::= empty | `(' tree char tree `)'
+//
+// disambiguated by deciding that `(' starts a tree wherever a tree is
+// expected. Not ever-so pretty; parser combinator version left as an
+// exercise.
+let parse_tree string =
+ let n = String.length string
+ let rec parse i =
+ match i with
+ | i when i < n && string.[i] = '(' ->
+ let left, i = parse (i + 1)
+ if i >= n then failwith "no data"
+ let data = string.[i]
+ let right, i = parse (i + 1)
+ if i >= n || string.[i] <> ')' then failwith "missing )"
+ Node (left, data, right), i + 1
+ | _ -> Leaf, i
+ let tree, i = parse 0
+ if i < n then failwith "trailing junk"
+ tree
+
+// Return an iterator for the elements of T in order.
+let iterate_fringe t =
+ let rec itfn t tail =
+ match t with
+ | Leaf -> tail ()
+ | Node (l, ch, r) ->
+ itfn l <| fun () -> Some (ch, Iter <| fun () -> itfn r tail)
+ Iter <| fun () -> itfn t <| fun () -> None
+
+///--------------------------------------------------------------------------
+/// Main program.
+
+let program_name = (System.Environment.GetCommandLineArgs ()).[0]
+
+[<EntryPoint>]
+let main args =
+ let run = function
+ | [| a |] ->
+ a |> parse_tree
+ |> iterate_fringe
+ |> fold_iterator (fun ch _ -> stdout.Write(ch)) ()
+ stdout.Write('\n')
+ | [| a; b |] ->
+ if same_iterators_p
+ (a |> parse_tree |> iterate_fringe)
+ (b |> parse_tree |> iterate_fringe)
+ then stdout.WriteLine("match")
+ else stdout.WriteLine("no match")
+ | _ -> failwith "bad args"
+ try
+ run args
+ 0
+ with
+ | exc ->
+ fprintf stderr "%s: %s\n" program_name exc.Message
+ 1
+
+///----- That's all, folks --------------------------------------------------
--- /dev/null
+-- -*-haskell-*-
+--
+-- Haskell implementation of a `same-fringe' solver.
+
+import IO
+import System
+import Monad
+
+-----------------------------------------------------------------------------
+-- Tree data type.
+
+data Tree a = Leaf | Node (Tree a, a, Tree a) deriving (Show)
+
+-- Return the elements inorder, as a list.
+fringe t = gather t [] where
+ gather Leaf ns = ns
+ gather (Node (l, x, r)) ns = gather l (x : gather r ns)
+
+-- Answer whether two trees have the same fringe.
+sameFringe t tt = fringe t == fringe tt -- trivial!
+
+-----------------------------------------------------------------------------
+-- Parsing.
+
+-- Turn Either String a into a monad expressing computatations which can fail
+-- with a useful error message.
+instance Monad (Either String) where
+ return = Right
+ fail = Left
+ Right x >>= f = f x
+ Left l >>= _ = Left l
+
+-- Parse a tree from the description in CS. The syntax is:
+--
+-- tree ::= empty | `(' tree char tree `)'
+--
+-- disambiguated by deciding that `(' starts a tree wherever a tree is
+-- expected.
+parseTree cs = do
+ (t, cs) <- parse cs
+ if cs == [] then return t else fail "trailing junk"
+ where
+ parse ('(':cs) = do
+ (left, cs) <- parse cs
+ case cs of
+ [] -> fail "no data"
+ (c:cs) -> do
+ (right, cs) <- parse cs
+ case cs of
+ (')':cs) -> return (Node (left, c, right), cs)
+ _ -> fail "missing )"
+ parse cs = return (Leaf, cs)
+
+-----------------------------------------------------------------------------
+-- Main program.
+
+-- Report MSG as an error and quit.
+bail msg = do
+ prog <- getProgName
+ hPutStrLn stderr (prog ++ ": " ++ msg)
+ exitFailure
+
+-- Main program.
+main = do
+ argv <- getArgs
+ case argv of
+ [arg] -> case parseTree arg of
+ Right t -> do
+ mapM_ putChar (fringe t)
+ putChar '\n'
+ Left err -> bail err
+ [a, b] -> case (parseTree a, parseTree b) of
+ (Right t, Right tt) ->
+ if sameFringe t tt then
+ putStrLn "match"
+ else
+ putStrLn "no match"
+ (Left err, _) -> bail err
+ (_, Left err) -> bail err
+ _ -> bail "bad args"
+
+----- That's all, folks -----------------------------------------------------
--- /dev/null
+### -*-icon-*-
+###
+### An Icon implementation of a `same-fringe' solver.
+
+###--------------------------------------------------------------------------
+### Utilities.
+
+procedure bail(msg)
+ ## Report MSG as an error, and quit.
+
+ write(&errout, &progname, ": ", msg)
+ flush(&errout)
+ exit(1)
+end
+
+procedure same_sequence_p(test, aseq, bseq)
+ ## Succeed if the sequences generated by coexpressions ASEQ and BSEQ equal,
+ ## in the sense that TEST succeeds when applied to corresponding elements,
+ ## and the sequences have the same length.
+
+ local a, b
+
+ while a := @aseq do
+ if not (b := @bseq) | not test(a, b) then fail
+ if @bseq then fail
+ return
+end
+
+procedure print_sequence(aseq)
+ ## Write the elements of the sequence generated by coexpression ASEQ
+ ## followed by a newline.
+
+ every writes(|@aseq)
+ write()
+end
+
+procedure string_equal_p(a, b)
+ ## Succeed if strings A and B are equal. Useful as a TEST for
+ ## `print_sequence'.
+
+ return a == b
+end
+
+###--------------------------------------------------------------------------
+### Node structure.
+
+record node(left, data, right)
+## A simple binary tree structure.
+
+procedure fringe(node)
+ ## Generate the elements of the tree headed by NODE inorder.
+
+ if /node then fail
+ suspend fringe(node.left) | node.data | fringe(node.right)
+end
+
+procedure scan_tree()
+ ## Scan a tree from the current subject, advancing the position over it.
+ ## See `parse_tree' for the syntax.
+
+ local data, left, right
+
+ if ="(" then {
+ left := scan_tree()
+ data := move(1) | bail("no data")
+ right := scan_tree()
+ =")" | bail("missing )")
+ return node(left, data, right)
+ } else
+ return &null
+end
+
+procedure parse_tree(string)
+ ## Parse a tree from STRING and return its root.
+ ##
+ ## The syntax is as follows.
+ ##
+ ## tree ::= empty | `(' tree char tree `)'
+ ##
+ ## Ambiguity is resolved by treating a `(' as starting a tree when a tree
+ ## is expected.
+
+ local t
+
+ return string ? {
+ t := scan_tree()
+ if not pos(0) then bail("trailing junk")
+ t
+ }
+end
+
+###--------------------------------------------------------------------------
+### Main program.
+
+procedure main(argv)
+ local trees
+
+ if *argv = 1 then
+ print_sequence(create fringe(parse_tree(argv[1])))
+ else if *argv = 2 then
+ if same_sequence_p(string_equal_p,
+ create fringe(parse_tree(argv[1])),
+ create fringe(parse_tree(argv[2]))) then
+ write("match")
+ else
+ write("no match")
+ else
+ bail("bad args")
+end
+
+###----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-scheme-*-
+;;;
+;;; Scheme implementation of a `same-fringe' solver. Assumes Chicken, but
+;;; should port easily.
+
+(use syntax-case) ; Chicken-specfic
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(define-syntax with-values
+ ;; Bind the values returned by FORM to the VARS and evaluate BODY.
+
+ (syntax-rules ()
+ ((with-values vars form . body)
+ (call-with-values (lambda () form)
+ (lambda stuff
+ (apply (lambda vars . body) stuff))))))
+
+(define-syntax when
+ ;; If CONDITION is not #f then evaluate BODY.
+
+ (syntax-rules ()
+ ((when condition . body)
+ (if condition (begin . body)))))
+
+(define-syntax unless
+ ;; If CONDITION is #f then evaluate BODY.
+
+ (syntax-rules ()
+ ((unless condition . body)
+ (if (not condition) (begin . body)))))
+
+;;;--------------------------------------------------------------------------
+;;; Coroutines.
+
+(define-record-type coroutine
+ ;; A coroutine simply remembers the continuaton which was suspended when it
+ ;; last invoked a different coroutine.
+ (make-coroutine continuation)
+ coroutine?
+ (continuation %coroutine-continuation %set-coroutine-continuation!))
+
+(define %current-coroutine (make-coroutine #f))
+(define (current-coroutine)
+ ;; Return the current coroutine.
+ %current-coroutine)
+
+(define %calling-coroutine #f)
+(define (calling-coroutine)
+ ;; Return the coroutine that invoked the current one. Before any switch,
+ ;; this is #f.
+ %calling-coroutine)
+
+(define (switch-cr coroutine . args)
+ ;; Switch to COROUTINE, passing it ARGS. When this coroutine is resumed
+ ;; (by calling `switch', naturally) it will return the values passed as
+ ;; arguments. A new coroutine (made by `make-coroutine') receives these
+ ;; values as its arguments.
+
+ (call-with-current-continuation
+ (lambda (k)
+ (%set-coroutine-continuation! %current-coroutine k)
+ (set! %calling-coroutine %current-coroutine)
+ (set! %current-coroutine coroutine)
+ (apply (%coroutine-continuation coroutine) args))))
+
+;;;--------------------------------------------------------------------------
+;;; Generators.
+
+(define-syntax define-generator
+ ;; Define a function returning a generator. The generator yields whatever
+ ;; the function body does.
+
+ (syntax-rules ()
+ ((define-generator (name . args) . body)
+ (define (name . args)
+ (make-coroutine (lambda ()
+ (begin . body)
+ (switch-cr (calling-coroutine) #f #f)))))))
+
+(define (yield object)
+ ;; Yield OBJECT from a generator. The generator protocol returns two
+ ;; values each time: either an object and #t, or #f twice to mark the end
+ ;; of the sequence.
+
+ (with-values () (switch-cr (calling-coroutine) object #t) #f))
+
+(define (list-generator gen)
+ ;; Collect the elements generated by GEN into a list and return it.
+
+ (let loop ((l '()))
+ (with-values (it any?) (switch-cr gen)
+ (if any?
+ (loop (cons it l))
+ (reverse l)))))
+
+(define (same-generators? gen-a gen-b)
+ ;; Return whether GEN-A and GEN-B generate the same elements in the same
+ ;; order.
+
+ (let loop ()
+ (with-values (a any-a?) (switch-cr gen-a)
+ (with-values (b any-b?) (switch-cr gen-b)
+ (cond ((not any-a?) (not any-b?))
+ ((not any-b?) #f)
+ ((eqv? a b) (loop))
+ (else #f))))))
+
+;;;--------------------------------------------------------------------------
+;;; Nodes and trees.
+
+;; Assumes SRFI-9; widely available.
+(define-record-type node
+ ;; A node in a simple binary tree. Empty subtrees are denoted by ().
+
+ (make-node left data right)
+ node?
+ (left node-left)
+ (data node-data)
+ (right node-right))
+
+(define-generator (fringe node)
+ ;; Generate the elements of the tree headed by NODE inorder.
+
+ (let recur ((node node))
+ (unless (null? node)
+ (recur (node-left node))
+ (yield (node-data node))
+ (recur (node-right node)))))
+
+(define (parse-tree string)
+ ;; Return a tree constructed according to STRING.
+ ;;
+ ;; Syntax is:
+ ;;
+ ;; tree ::= empty | `(' tree char tree `)'
+ ;;
+ ;; disambiguated by treating `(' as starting a tree wherever a tree is
+ ;; expected.
+
+ (let ((len (string-length string)))
+ (define (parse i)
+ (cond ((>= i len) (values '() i))
+ ((char=? (string-ref string i) #\()
+ (with-values (left i) (parse (+ 1 i))
+ (unless (< i len) (error "no data"))
+ (let ((data (string-ref string i)))
+ (with-values (right i) (parse (+ 1 i))
+ (unless (and (< i len) (char=? (string-ref string i) #\)))
+ (error "missing )"))
+ (values (make-node left data right) (+ 1 i))))))
+ (else (values '() i))))
+ (with-values (tree i) (parse 0)
+ (unless (= i len) (error "trailing junk"))
+ tree)))
+
+;;;--------------------------------------------------------------------------
+;;; Main program.
+
+(define (main args)
+ (cond ((null? args) (error "bad args"))
+ ((null? (cdr args))
+ (do ((l (list-generator (fringe (parse-tree (car args)))) (cdr l)))
+ ((null? l))
+ (write-char (car l)))
+ (newline))
+ ((null? (cddr args))
+ (display (if (same-generators? (fringe (parse-tree (car args)))
+ (fringe (parse-tree (cadr args))))
+ "match"
+ "no match"))
+ (newline))
+ (else (error "bad args"))))
+
+;; Chicken-specific (works in interpreter and standalone compiled code).
+(let ((program (car (argv))))
+ (condition-case (begin (main (command-line-arguments)) (exit))
+ (err (exn)
+ (print-error-message err (current-error-port) program)
+ (exit 1))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+"-*-smalltalk-*-
+
+Smalltalk implementation of a `same-fringe' solver.
+
+Use GNU Smalltalk syntax -- it seems more Emacs-friendly.
+"
+
+Object subclass: Node [
+ | left right data |
+
+ <comment: 'I represent simple binary tree nodes. My instances consist of
+a data object, and left and right subtrees. The leaves of a tree are
+instances of LeafNode.'>
+ <category: 'Toys-SameFringe'>
+
+ Node class >> left: aNode data: anObject right: anotherNode [
+ "Answer a newly tree Node with the given subtrees and data."
+
+ <category: 'instance creation'>
+ ^self new left: aNode data: anObject right: anotherNode
+ ]
+
+ Node class >> parse: aString [
+ "Answer a newly constructed tree, parsed from aString."
+
+ <category: 'parsing'>
+ | stream tree |
+ stream := ReadStream on: aString.
+ tree := stream parseTree.
+ stream atEnd ifFalse: [self error: 'trailing junk'].
+ ^tree
+ ]
+
+ left: aNode data: anObject right: anotherNode [
+ "Initialize a (presumably) new instance."
+
+ <category: 'initialization'>
+ left := aNode.
+ right := anotherNode.
+ data := anObject.
+ ^self
+ ]
+
+ left [
+ "Answer the receiver's left subtree."
+
+ <category: 'accessing'>
+ ^left
+ ]
+
+ right [
+ "Answer the receiver's right subtree."
+
+ <category: 'accessing'>
+ ^right
+ ]
+
+ data [
+ "Answer the receiver's data."
+
+ <category: 'accessing'>
+ ^data
+ ]
+
+ isLeaf [
+ "Answer false, becase the receiver is not a leaf."
+
+ <category: 'testing'>
+ ^false
+ ]
+
+ iterator [
+ "Answer a new iterator to walk this node."
+
+ <category: 'iteration'>
+ ^NodeIterator for: self
+ ]
+
+ inorderTell: aBlock tell: aNodeIterator [
+ "This is the hairy part of the iteration protocol.
+
+ The algorithm works like this. We're meant to wander as far down
+ the left of the tree as we can; once we're there, we call
+ aNodeIterator with the data we found and a block which will continue
+ the iteration over the rest of the tree and finally invoke aBlock.
+
+ Observe that there are no explicit conditionals here. It's all done
+ with object dispatch. And smoke. And mirrors.
+
+ Also note that this is tail-recursive. The `stack' is built up in
+ the hairy block constructions, which all go on the heap."
+
+ <category: 'private iteration'>
+ left
+ inorderTell:
+ [aNodeIterator
+ found: data
+ then: [right inorderTell: aBlock tell: aNodeIterator]]
+ tell: aNodeIterator
+ ]
+
+ sameFringeAs: aNode [
+ "Answer whether traversing the receiver inorder yields the same
+ objects as traversing aNode."
+
+ <category: 'comparison'>
+ | ia ib |
+ ia := self iterator.
+ ib := aNode iterator.
+ [ia atEnd] whileFalse:
+ [ib atEnd ifTrue: [^false].
+ (ia next = ib next) ifFalse: [^false]].
+ ^ib atEnd
+ ]
+
+ displayOn: aStream [
+ "Write a simple representation of self to the stream."
+
+ <category: 'printing'>
+ aStream nextPut: $(;
+ display: left;
+ display: data;
+ display: right;
+ nextPut: $)
+ ]
+
+ Node class >> main: anArray [
+ "Noddy script main program."
+
+ <category: 'command line'>
+ [(Dictionary new
+ at: 1 put:
+ [(self parse: (anArray at: 1)) iterator do:
+ [:char | FileStream stdout nextPut: char].
+ FileStream stdout nl];
+ at: 2 put:
+ [FileStream stdout display:
+ (((self parse: (anArray at: 1))
+ sameFringeAs: (self parse: (anArray at: 2)))
+ ifTrue: ['match']
+ ifFalse: ['no match']);
+ nl ];
+ at: anArray size ifAbsent: [self error: 'bad args'])
+ value]
+ on: Error do:
+ [:error |
+ FileStream stderr
+ nextPutAll: 'smalltalk-fringe: ';
+ nextPutAll: error messageText;
+ nl.
+ ^1].
+ ^0
+ ]
+]
+
+PositionableStream extend [
+ parseTree [
+ "Answer a newly constructed tree, parsed from the receiver.
+
+ The syntax is very simple:
+
+ tree ::= empty | `(' tree char tree `)'
+
+ where char is any character. Ambiguity is resolved by deciding that
+ something beginning with `(' where a tree is expected really is a
+ tree and not an empty tree followed by the char `('."
+
+ <category: 'parsing'>
+ | left data right |
+
+ self peek = $( ifFalse: [^LeafNode instance].
+ self next.
+ left := self parseTree.
+ self atEnd ifTrue: [self error: 'no data'].
+ data := self next.
+ right := self parseTree.
+ self next = $) ifFalse: [self error: 'missing )'].
+ ^Node left: left data: data right: right
+ ]
+]
+
+Object subclass: LeafNode [
+ <comment: 'I represent the leaves of a tree of Nodes. I don''t hold any
+kind of interesting state. My methods provide the base cases for some of the
+recursive protocols used to handle Nodes.'>
+ <category: 'Toys-SameFringe'>
+
+ instance := LeafNode new.
+
+ displayOn: aStream [
+ "Write a simple representation of self to the stream."
+
+ <category: 'printing'>
+ "Nothing to do!"
+ ]
+
+ isLeaf [
+ "Answer true, because the receiver is a leaf node."
+
+ <category: 'testing'>
+ ^true
+ ]
+
+ iterator [
+ "Return a new iterator to walk this node."
+
+ <category: 'iteration'>
+ ^NodeIterator for: self
+ ]
+
+ inorderTell: aBlock tell: aNodeIterator [
+ "This is the hairy part of the iteration protocol.
+
+ But in this case it's simple. We've overshot the end, so we just
+ need to call aBlock to persuade our parent to announce itself to the
+ iterator."
+
+ <category: 'private iteration'>
+ aBlock value
+ ]
+
+ LeafNode class >> instance [
+ "Return the unique instance of the leaf node."
+
+ <category: 'singleton'>
+ ^instance
+ ]
+]
+
+Stream subclass: NodeIterator [
+ | item rest |
+
+ <comment: 'I hold the state for external iteration of trees of Nodes and
+(halfheartedly) implement the Stream protocol.'>
+ <category: 'Toys-SameFringe'>
+
+ found: anObject then: aBlock [
+ "Stash the newly found item from the hairy iteration protocol.
+
+ When the iteration protocol decides on the next leftmost item to
+ return, it gives us anObject that it found, and aBlock which will
+ continue until it finds the next object."
+
+ <category: 'private iteration'>
+ item := anObject.
+ rest := aBlock.
+ ]
+
+ NodeIterator class >> for: aNode [
+ "Answer a new iterator for the tree starting at aNode."
+
+ <category: 'instance creation'>
+ ^self new walk: aNode
+ ]
+
+ walk: aNode [
+ "Start walking a subtree starting at aNode.
+
+ We get the node to iterate itself and finally tell us that it's
+ finished."
+
+ <category: 'initialization'>
+ aNode inorderTell: [rest := nil] tell: self
+ ]
+
+ next [
+ "Answer the next element from the tree, or nil if we've hit the end."
+
+ <category: 'reading'>
+ | it |
+ rest ifNil: [^nil].
+ it := item.
+ rest value.
+ ^it
+ ]
+
+ peek [
+ "Answer the next element without removing it."
+
+ <category: 'reading'>
+ rest ifNil: [^nil] ifNotNil: [^item]
+ ]
+
+ atEnd [
+ "Answer whether we have reached the end of the iteration."
+
+ <category: 'testing'>
+ ^rest isNil
+ ]
+]
--- /dev/null
+#! /bin/sh
+
+###--------------------------------------------------------------------------
+### Framework.
+
+prog=${1?prog}
+progbase=${prog##*/}
+lose=0
+
+clean () {
+ rm -f test.out test.err test.rc
+}
+
+run () {
+ clean
+ echo >&2 "Running $prog $*"
+ $prog "$@" >test.out 2>test.err
+ echo $? >test.rc
+ for i in out err rc; do
+ echo "$i"
+ sed 's/^/ /' test.$i
+ done >&2
+}
+
+lose () {
+ echo >&2 "$*"
+ lose=1
+}
+
+insist () {
+ case $(cat test.$1) in
+ $2) ;;
+ *) lose "!!! expected $1 to match \`$2'." ;;
+ esac
+}
+
+insist_fail () {
+ insist rc "[!0]*"
+ insist err "*$progbase: $1"
+}
+
+insist_win () {
+ insist rc 0
+ insist out "$1"
+}
+
+###--------------------------------------------------------------------------
+### Tests.
+
+tree_a="((a)b((c)d(e)))"
+tree_b="((((a)b(c))d)e)"
+tree_c="((((a)c(b))d)e)"
+
+tree_x="(((a)b((c)d(e)))f((((g)h(i))j(k))l(m)))"
+tree_y="(((a)b((c)d(e(f))))g(((h)i((j)k(l)))m))"
+tree_z="(((a)b((c)d(e)))f((((g)h)j(k))l(m)))"
+
+run
+ insist_fail "bad args"
+
+run foo bar baz
+ insist_fail "bad args"
+
+run $tree_a
+ insist_win "abcde"
+
+run "((a)b((c)d(e))"
+ insist_fail "missing )"
+
+run "((a)b((c)d(e)))z"
+ insist_fail "trailing junk"
+
+run "((a)b((c)d("
+ insist_fail "no data"
+
+run $tree_a $tree_b
+ insist_win "match"
+
+run $tree_a $tree_c
+ insist_win "no match"
+
+run $tree_x $tree_y
+ insist_win "match"
+
+run $tree_x $tree_z
+ insist_win "no match"
+
+run $tree_z $tree_y
+ insist_win "no match"
+
+###--------------------------------------------------------------------------
+### Done.
+
+clean
+exit $lose
+
+###----- That's all, folks --------------------------------------------------
~mdw / fringe / commitdiff