shannon@luap.cs.indiana.edu (Greg Shannon) (04/08/91)
In inadvertantly, a buggy template for the algorithm was included
in the anonymous FTP distribution of this code (from iuvax.cs.indiana.edu).
The corrected template is included here and has been added to the
distribution files.
Greg Shannon
;;;*************************************************************************
;;; Copyright (c) 1990 Manoj K. Jain
;;; Copyright (c) 1990 Yao-Chung Lee
;;; Copyright (c) 1990 Gregory Shannon
;;; All rights reserved
;;;*************************************************************************
;;;*************************************************************************
;;; Template Q2 is the case where there is one partial children (Q node).
;;; The replacement is trivial as all one has to do is to gather all the empty
;;; children and full children and placed the empty children first, followed
;;; by the fullchildren on the original Q node. Thus the final PQ tree will
;;; have only one Q node with all the empty children on the left and the full
;;; full children on the right. The special case is when there are no empty
;;; or full children, and the replacement for this case is simply to replace
;;; the partial child in place of the original Q node.
;;;*************************************************************************
(define template_q2
(lambda (X S)
(set! labellist (makelabel X S PQTREE))
(set! partial_children_X (partial_children X labellist PQTREE))
(set! full_children_X (full_children X labellist PQTREE))
(set! empty_children_X (empty_children X labellist PQTREE))
(if (equal? (type X) 'q)
(set! endmost_children_x (endmost_children X PQTREE)))
(if (not (and (equal? (type X) 'q)
(<= (length partial_children_x) 1)))
#f
(begin
(if (and (> (length full_children_X) 0)
(not (= (length (intersection (extractnodes full_children_X)
(extractnodes endmost_children_X))) 1)))
#f
(begin
(if (= (length partial_children_x) 1)
(begin
(let ([Y (car partial_children_x)]
[num_fullchildren (length full_children_x)]
[num_emptychildren (length empty_children_x)]
[parent_x (parent X pqtree)])
(let ([EC (empty_endmost_children Y pqtree labellist)])
(set! labellist (label Y 'partial labellist))
(let ([childrenofq (extractnodes (children Y pqtree))])
(if (not (equal? (car childrenofq) (car EC)))
(set! childrenofq (reverse childrenofq)))
(if (and (= num_fullchildren 0)
(> num_emptychildren 0))
(begin
(set! Y (append (list Y) (append
(fullchildrenlist empty_children_x pqtree)
(fullchildrenlist childrenofq pqtree))))
(set! pqtree (replace-node X Y pqtree)))
(begin
(if (and (> num_fullchildren 0)
(= num_emptychildren 0))
(begin
(set! Y (append (list Y)
(append (fullchildrenlist childrenofq pqtree)
(fullchildrenlist full_children_x pqtree))))
(set! pqtree (replace-node X Y pqtree)))
(begin
(set! Y (append (list Y) (append
(fullchildrenlist empty_children_x pqtree)
(fullchildrenlist childrenofq pqtree)
(fullchildrenlist full_children_x pqtree))))
(set! pqtree (replace-node X Y pqtree)))))))))))
(set! pqtree (destroy X))
#t))))))