From 2bd37ef118cb1e41cb0e9e2332a9eb69ac2f2df4 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 17 Nov 2009 21:51:44 +0000 Subject: [PATCH] Initial version. --- .gitignore | 8 ++ Makefile | 132 ++++++++++++++++++++++++ c-fringe.c | 177 ++++++++++++++++++++++++++++++++ cl-fringe.lisp | 110 ++++++++++++++++++++ f#-fringe.fs | 123 ++++++++++++++++++++++ haskell-fringe.hs | 82 +++++++++++++++ icon-fringe.icn | 111 ++++++++++++++++++++ scheme-fringe.scm | 183 +++++++++++++++++++++++++++++++++ smalltalk-fringe.st | 290 ++++++++++++++++++++++++++++++++++++++++++++++++++++ test | 97 ++++++++++++++++++ 10 files changed, 1313 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 c-fringe.c create mode 100644 cl-fringe.lisp create mode 100644 f#-fringe.fs create mode 100644 haskell-fringe.hs create mode 100644 icon-fringe.icn create mode 100644 scheme-fringe.scm create mode 100644 smalltalk-fringe.st create mode 100755 test diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..44e0f13 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*~ +#* +test.log +*.im +*.o +*.exe +*.hi +*-fringe diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..aac2437 --- /dev/null +++ b/Makefile @@ -0,0 +1,132 @@ +### 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) diff --git a/c-fringe.c b/c-fringe.c new file mode 100644 index 0000000..c45b9bb --- /dev/null +++ b/c-fringe.c @@ -0,0 +1,177 @@ +/* -*-c-*- + * + * Prosaic C implementation of a `same-fringe' solver. + */ + +#include +#include +#include + +/*----- 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 -------------------------------------------------*/ diff --git a/cl-fringe.lisp b/cl-fringe.lisp new file mode 100644 index 0000000..0081ee3 --- /dev/null +++ b/cl-fringe.lisp @@ -0,0 +1,110 @@ +;;; -*-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 -------------------------------------------------- diff --git a/f#-fringe.fs b/f#-fringe.fs new file mode 100644 index 0000000..efcc860 --- /dev/null +++ b/f#-fringe.fs @@ -0,0 +1,123 @@ +/// -*-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] + +[] +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 -------------------------------------------------- diff --git a/haskell-fringe.hs b/haskell-fringe.hs new file mode 100644 index 0000000..577bb6b --- /dev/null +++ b/haskell-fringe.hs @@ -0,0 +1,82 @@ +-- -*-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 ----------------------------------------------------- diff --git a/icon-fringe.icn b/icon-fringe.icn new file mode 100644 index 0000000..b32dbb7 --- /dev/null +++ b/icon-fringe.icn @@ -0,0 +1,111 @@ +### -*-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 -------------------------------------------------- diff --git a/scheme-fringe.scm b/scheme-fringe.scm new file mode 100644 index 0000000..53417dd --- /dev/null +++ b/scheme-fringe.scm @@ -0,0 +1,183 @@ +;;; -*-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 -------------------------------------------------- diff --git a/smalltalk-fringe.st b/smalltalk-fringe.st new file mode 100644 index 0000000..0d319da --- /dev/null +++ b/smalltalk-fringe.st @@ -0,0 +1,290 @@ +"-*-smalltalk-*- + +Smalltalk implementation of a `same-fringe' solver. + +Use GNU Smalltalk syntax -- it seems more Emacs-friendly. +" + +Object subclass: Node [ + | left right data | + + + + + Node class >> left: aNode data: anObject right: anotherNode [ + "Answer a newly tree Node with the given subtrees and data." + + + ^self new left: aNode data: anObject right: anotherNode + ] + + Node class >> parse: aString [ + "Answer a newly constructed tree, parsed from aString." + + + | 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." + + + left := aNode. + right := anotherNode. + data := anObject. + ^self + ] + + left [ + "Answer the receiver's left subtree." + + + ^left + ] + + right [ + "Answer the receiver's right subtree." + + + ^right + ] + + data [ + "Answer the receiver's data." + + + ^data + ] + + isLeaf [ + "Answer false, becase the receiver is not a leaf." + + + ^false + ] + + iterator [ + "Answer a new iterator to walk this node." + + + ^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." + + + 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." + + + | 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." + + + aStream nextPut: $(; + display: left; + display: data; + display: right; + nextPut: $) + ] + + Node class >> main: anArray [ + "Noddy script main program." + + + [(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 `('." + + + | 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 [ + + + + instance := LeafNode new. + + displayOn: aStream [ + "Write a simple representation of self to the stream." + + + "Nothing to do!" + ] + + isLeaf [ + "Answer true, because the receiver is a leaf node." + + + ^true + ] + + iterator [ + "Return a new iterator to walk this node." + + + ^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." + + + aBlock value + ] + + LeafNode class >> instance [ + "Return the unique instance of the leaf node." + + + ^instance + ] +] + +Stream subclass: NodeIterator [ + | item rest | + + + + + 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." + + + item := anObject. + rest := aBlock. + ] + + NodeIterator class >> for: aNode [ + "Answer a new iterator for the tree starting at aNode." + + + ^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." + + + aNode inorderTell: [rest := nil] tell: self + ] + + next [ + "Answer the next element from the tree, or nil if we've hit the end." + + + | it | + rest ifNil: [^nil]. + it := item. + rest value. + ^it + ] + + peek [ + "Answer the next element without removing it." + + + rest ifNil: [^nil] ifNotNil: [^item] + ] + + atEnd [ + "Answer whether we have reached the end of the iteration." + + + ^rest isNil + ] +] diff --git a/test b/test new file mode 100755 index 0000000..03bebc4 --- /dev/null +++ b/test @@ -0,0 +1,97 @@ +#! /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 -------------------------------------------------- -- 2.11.0