algol68-fringe: New language.

[fringe] / cl-fringe.lisp

;;; -*-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 reduce-iterator (func init iter)
  "Invoke FUNC on the elements of ITER.

   We maintain a STATE whose value initially is INIT; for each ITEM, we
   update the state with the value of (funcall FUNC ITEM STATE); the end
   result is the final state."
  (let ((state init) item)
    (loop
      (setf (values item iter) (funcall iter))
      (unless iter (return state))
      (setf state (funcall func item state)))))

(defun list-iterator (iter)
  "Collect the items from ITER into a list and return it."
  (nreverse (reduce-iterator #'cons nil iter)))

(defun iterate-list (list)
  "Return an iterator for LIST, according to our iteration protocol."
  (if (endp list)
      (lambda () (values nil nil))
      (lambda () (values (car list) (iterate-list (cdr list))))))

(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 ((and (< i len) (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 (prog args)
  "Main program: process ARGS."
  (flet ((bail (format args)
	   (format *error-output* "~A: ~?~%" prog format args)
	   (return-from main 1)))
    (handler-case
	(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)))))))
	(simple-error (err)
	  (bail (simple-condition-format-control err)
		(simple-condition-format-arguments err)))
	(error (err)
	  (bail "~A" err)))
    0))

#+cl-launch
(defun launch ()
  (cl-launch:quit (main (or (cl-launch:getenv "CL_LAUNCH_FILE")
			    (namestring *load-pathname*)
			    "<unknown>")
			cl-launch:*arguments*)))

#+(and (not cl-launch) ecl)
(ext:quit (main (ext:argv 0)
		(loop for i from 1 below (ext:argc) collect (ext:argv i))))

#+(and (not cl-launch) sbcl)
(sb-ext:quit :unix-status (main (pathname-name *load-pathname*)
				(cdr sb-ext:*posix-argv*)))

;;;----- That's all, folks --------------------------------------------------