#-(and) "

Multiway Trees

A multiway tree is composed of a root element and a (possibly empty)
set of successors which are multiway trees themselves. A multiway tree
is never empty. The set of successor trees is sometimes called a
forest.

[p70]

In Prolog we represent a multiway tree by a term t(X,F), where X
denotes the root node and F denotes the forest of successor trees (a
Prolog list). The example tree depicted opposite is therefore
represented by the following Prolog term:

T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])

"

;; In lisp we could represent a multiway tree in multiple ways.
;; Let's just abstract it away using defstruct.

(defstruct (multiway-tree
(:predicate non-empty-multiway-tree-p))

label
children)

;; Again, if lists are wanted instead of structures, (:type list) can
;; be used; if vectors, then (:type vector).  In both cases, if the
;; list or vector must start with the symbol MULTIWAY-TREE, the :named

(defun make-empty-multiway-tree ()
'nil)
(defun empty-multiway-tree-p (tree)
(null tree))

(defun multiway-tree-p (tree)
(or (empty-multiway-tree-p tree)
(non-empty-multiway-tree-p tree)))

#-(and) "

P70B (*) Check whether a given term represents a multiway tree

Write a predicate istree/1 which succeeds if and only if its
argument is a Prolog term representing a multiway tree.

Example:
* istree(t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])).
Yes
"

(defun istree (tree)
(multiway-tree-p tree))

;; In practice, nothing more than the badass solution is needed.  For
;; the exercise, we may check that the children are multiway trees
;; too.

(defun istree (tree)
(cond
((empty-multiway-tree-p tree) t)
((non-empty-multiway-tree-p tree)
(every (function istree) (multiway-tree-children tree)))))

;; Actually, in presence of circular structures, the above istree may
;; not terminate.  Since those exercices are boring, we'll implement
;; an istree that checks for circular structures too:

(defun istree (tree)
(let ((nodes (make-hash-table)))
(labels ((multiway-node-p (node)
(cond
((empty-multiway-tree-p node)           t)
((not (non-empty-multiway-tree-p node))
(return-from istree (values nil :non-tree node))) ; short circuit exit
((gethash node nodes)
(return-from istree (values nil :circular node))) ; short circuit exit
(t
(setf (gethash node nodes) t)
(every (function multiway-node-p) (multiway-tree-children node))))))
(multiway-node-p tree))))

(let* ((child (make-multiway-tree :label 'child))
(root  (make-multiway-tree :label 'root :children (list child))))
(setf (multiway-tree-children child) (list root))
(assert (equal (list nil :circular root) (multiple-value-list (istree root)))))

(let* ((child (make-multiway-tree :label 'child :children '(a b c)))
(root  (make-multiway-tree :label 'root :children (list child))))
(assert (equal '(nil :non-tree a) (multiple-value-list (istree root)))))

(let* ((child (make-multiway-tree
:label 'child
:children (list (make-multiway-tree :label 'a)
(make-multiway-tree :label 'b)
(make-multiway-tree :label 'c))))
(root  (make-multiway-tree :label 'root :children (list child))))
(assert (istree root)))

;; Notice that CL provides for each structure a printer function
;; producing a readable form of the structure:
;;
;; (let* ((child (make-multiway-tree
;;                :label 'child
;;                :children (list (make-multiway-tree :label 'a)
;;                                (make-multiway-tree :label 'b)
;;                                (make-multiway-tree :label 'c))))
;;        (root  (make-multiway-tree :label 'root :children (list child))))
;;   root)
;; --> #S(MULTIWAY-TREE
;;        :LABEL ROOT
;;        :CHILDREN (#S(MULTIWAY-TREE
;;                      :LABEL CHILD
;;                      :CHILDREN (#S(MULTIWAY-TREE :LABEL A :CHILDREN NIL)
;;                                   #S(MULTIWAY-TREE :LABEL B :CHILDREN NIL)
;;                                   #S(MULTIWAY-TREE :LABEL C :CHILDREN NIL)))))
;;
;;
;;
;; So we can also write literal multiway-trees as:
;;
;; #S(multiway-tree :label example :children (#S(multiway-tree :label a) #S(multiway-tree :label b)))
;; --> #S(MULTIWAY-TREE :LABEL EXAMPLE
;;                      :CHILDREN (#S(MULTIWAY-TREE :LABEL A :CHILDREN NIL)
;;                                   #S(MULTIWAY-TREE :LABEL B :CHILDREN NIL)))

;;;; END ;;;;
ViewGit