home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
vis-ftp.cs.umass.edu
/
vis-ftp.cs.umass.edu.tar
/
vis-ftp.cs.umass.edu
/
pub
/
Software
/
ASCENDER
/
ascendMar8.tar
/
UMass
/
ISR
/
isr2tss.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1995-04-11
|
59KB
|
1,512 lines
;;; -*- Mode:Common-Lisp; Package:isr2; Base:10; -*-
;;;------------------------------------------------------------------------
;;; ISR2TSS.LISP - Token[sub]sequence functions
;;; Created: Wed May 18 10:07:22 1988
;;; Author: Robert Heller
;;;------------------------------------------------------------------------
;;; Copyright (c) University of Massachusetts 1988
;;;------------------------------------------------------------------------
(in-package "ISR2")
(export '(make-tss make-null-tss make-null-tss! token-count make-tss-extents
tss-extents-minrow tss-extents-mincol tss-extents-maxrow tss-extents-maxcol
tss-extents tss-extents-p copy-tss-extents make-range range-min range-max
range-feature range-circular-p range range-p copy-range make-predicate
predicate-function predicate-features predicate predicate-p copy-predicate
tss-intersection tss-intersection! tss-union tss-union! tss-set-difference
tss-set-difference! tss-sort tss-sort-key sort-update! tss-mem pick pick-reset!
for-every-token for-every-token! for-every-feature! add-tokens add-tokens!
remove-tokens remove-tokens! optimize-tss-storage add-token add-token!
remove-token remove-token! pick pick-reset! compress tss-make-sort
tss-sort-by-predicate))
(defun tss-index-memq (index tss-existence-vector)
(cond ((typep tss-existence-vector '2index-vector-vector)
(= (vvref tss-existence-vector index) 1))
(t (not (null (member index tss-existence-vector))))))
(defun make-tss (path &aux parsed-path handle more-parsed-path)
"Make a new TSS from path."
(setf parsed-path (parse-token-name path))
(multiple-value-setq (handle more-parsed-path)
(make-handle-from-parsed-path parsed-path))
(unless (and handle
(check-terminal-path handle more-parsed-path)
(member (handle-type handle) '(:frame :token-subset
:token-sort))
(null more-parsed-path))
(error "~S is not a legitimate path!" path))
(make-handle :type :token-subset
:frame (handle-frame handle)
:token-existence-array
(cond ((eq (handle-type handle) :frame)
(deep-copy-evv (frame-token-set-globalp-vector
(handle-frame handle))))
((eq (handle-type handle) :token-sort)
(let ((new-evv (deep-copy-evv (handle-token-existence-array
handle))))
(when (listp new-evv)
(setf new-evv (sort new-evv #'<)))
new-evv))
(t (deep-copy-evv (handle-token-existence-array
handle)))))
)
(defun make-null-tss (path &aux parsed-path handle more-parsed-path)
"Make a new TSS from path."
(setf parsed-path (parse-token-name path))
(multiple-value-setq (handle more-parsed-path)
(make-handle-from-parsed-path parsed-path))
(unless (and handle
(check-terminal-path handle more-parsed-path)
(member (handle-type handle) '(:frame :token-subset
:token-sort))
(null more-parsed-path))
(error "~S is not a legitimate path!" path))
(make-handle :type :token-subset
:frame (handle-frame handle)
:token-existence-array nil)
)
(defun deep-copy-evv (e-vector)
(cond ((typep e-vector '2index-vector-vector)
(deep-copy-evv-2vv-optimize e-vector))
(t (deep-copy-evv-tis-optimize e-vector)))
)
;; when a 2vv is < 30% used, convert to a list
(defconstant 2VV-TO-TIS-OPT-RATIO 0.3)
;; when a list (if converted to a 2vv) would be > 80% used, convert it to a 2vv
(defconstant TIS-TO-2VV-OPT-RATIO 0.8)
(defun active-token-count-2vv (2vv)
"This function returns the number of active tokens."
(let ((count 0))
(do-active-tokens (tokindex 2vv)
(incf count))
count))
(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun total-token-count-2vv (2vv)
"This function retuns the total count of tokens."
(* (fill-pointer (2index-vector-vector-data 2vv))
*default-2index-vector-size*)
)
(defun compute-2VV-use-ratio (2vv)
(let ((number-of-active-tokens (active-token-count-2vv 2vv))
(allocated-token-count (* *default-2index-vector-size*
(2vv-used-block-count 2vv)))
)
(if (> number-of-active-tokens 0)
(/ (float number-of-active-tokens)
(float allocated-token-count))
0.0)
)
)
(defun compute-tis-use-ratio (tis)
(if (null tis)
0.0
(let ((number-of-active-tokens (length tis))
(allocated-token-count (figure-allocation tis))
)
(/ (float number-of-active-tokens)
(float allocated-token-count))
)
)
)
(defun 2vv-used-block-count (2vv)
(let* ((outer-vector (2index-vector-vector-data 2vv))
(ov-size (fill-pointer outer-vector))
(count 0))
(dotimes (ov ov-size)
(when (aref outer-vector ov)
(incf count)))
count)
)
(defun figure-allocation (tis &aux (min (reduce #'min tis))
(max (reduce #'max tis)))
(do ((count 0)
(istart (truncate min *default-2index-vector-size*)
(1+ istart)))
((> istart (truncate (+ max *default-2index-vector-size*)
*default-2index-vector-size*))
(* count *default-2index-vector-size*))
(when (some #'(lambda (tindx)
(and (>= tindx (* istart *default-2index-vector-size*)
)
(< tindx (* (1+ istart)
*default-2index-vector-size*)
)))
tis)
(incf count)))
)
(defun deep-copy-evv-2vv-optimize (2vv)
(let ((2vv-use-ratio (compute-2VV-use-ratio 2vv)))
(if (< 2vv-use-ratio 2VV-TO-TIS-OPT-RATIO)
(let* ((result (make-list (active-token-count-2vv 2vv)))
(p result))
(do-active-tokens (token-index 2vv)
(setf (first p) token-index
p (rest p)))
result)
(let* ((new-tok-exist (make-2index-vector-vector 0))
(old-outer-vector (2index-vector-vector-data 2vv))
(new-outer-vector (2index-vector-vector-data
new-tok-exist))
(old-fill-pointer (fill-pointer old-outer-vector))
old-inner-vector old-iv
new-inner-vector new-iv
)
(dotimes (ov old-fill-pointer)
(vector-push-extend nil new-outer-vector)
(when (setf old-inner-vector
(aref old-outer-vector ov))
(setf new-inner-vector
(allocate-resource
'2index-bin-vector
(* ov *default-2index-vector-size*))
new-iv (2index-vector-data-vector new-inner-vector)
old-iv (2index-vector-data-vector old-inner-vector)
(aref new-outer-vector ov) new-inner-vector
)
(dotimes (iv *default-2index-vector-size*)
(setf (aref new-iv iv)
(aref old-iv iv)))
)
)
new-tok-exist)
)
)
)
(defun deep-copy-evv-tis-optimize (tis)
(let ((tis-use-ratio (compute-tis-use-ratio tis)))
(if (> tis-use-ratio TIS-TO-2VV-OPT-RATIO)
(let ((new-tok-exist (make-2index-vector-vector 0)))
(map nil #'(lambda (iv)
(setf (vvref new-tok-exist iv) 1))
tis)
new-tok-exist)
(copy-seq tis))))
(defun make-null-tss! (tss)
"MAKE-NULL-TSS! tss - release storage used by tss. Tss *must* be a tss-handle.
This function is only meaningful iff tss's existence vector is a 2index
bit-vector. "
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "~S is not a TSS handle!" tss))
(let ((evv (handle-token-existence-array tss)))
(if (typep evv '2index-vector-vector)
(with-lock ((2index-vector-vector-lock evv))
(let* ((outer-vect (2index-vector-vector-data evv))
(ov-size (fill-pointer outer-vect))
ivect)
(dotimes (ov ov-size)
(setf ivect (aref outer-vect ov))
(when ivect
(deallocate-resource
(type-of ivect) ivect)
(setf (aref outer-vect ov) nil)
))
(setf (fill-pointer outer-vect) 0)
)
(setf (handle-token-existence-array tss) nil))
(setf (handle-token-existence-array tss) nil))
)
tss
)
(defun token-count (frame-or-tss &aux parsed-path handle more-parsed-path)
"TOKEN-COUNT frame-or-tss - Returns the number of active tokens in the
frame or TSS."
(setf parsed-path (parse-token-name frame-or-tss))
(multiple-value-setq (handle more-parsed-path)
(make-handle-from-parsed-path parsed-path))
(unless (and handle
(check-terminal-path handle more-parsed-path)
(member (handle-type handle) '(:frame :token-subset
:token-sort))
(null more-parsed-path))
(error "~S is not a legitimate path!" frame-or-tss))
(if (eq (handle-type handle) :frame)
(active-token-count-2vv (frame-token-set-globalp-vector
(handle-frame handle)))
(let ((evv (handle-token-existence-array
handle)))
(if (typep evv '2index-vector-vector)
(active-token-count-2vv evv)
(length evv))))
)
(defun optimize-tss-storage (tss &aux new-tss)
"OPTIMIZE-TSS-STORAGE tss - optimize TSS's storage. Does a MAKE-TSS on
tss and then frees the old tss and returns the new (copied) one."
(setf new-tss (make-tss tss))
(make-null-tss! tss)
new-tss)
(defun tss-intersection (path set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-INTERSECTION path set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the intersection of the TSS described by path and the TSS described
by set-description. If-uncalculated specifies what to do if a feature is
uncalculated (nil - skip, T - use, :calculate or :compute compute the
feature (i.e. call the :if-needed function(s))). If-undefined specifies
what to do if the feature is undefined (nil - skip, T - use, :calculate or
:compute - error). If-getting specifies whether to call the :if-getting
function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(tss-intersection! (make-tss path) set-description :if-uncalculated
if-uncalculated :if-getting if-getting :if-undefined
if-undefined))
(defun tss-union (path set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-UNION path set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the union of the TSS described by path and the TSS described
by set-description. If-uncalculated specifies what to do if a feature is
uncalculated (nil - skip, T - use, :calculate or :compute compute the
feature (i.e. call the :if-needed function(s)). If-undefined specifies
what to do if the feature is undefined (nil - skip, T - use, :calculate or
:compute - error). If-getting specifies whether to call the :if-getting
function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(tss-union! (make-tss path) set-description :if-uncalculated
if-uncalculated :if-getting if-getting :if-undefined
if-undefined))
(defun tss-difference (path set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-DIFFERENCE path set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the set difference of the TSS described by path and the TSS described
by set-description. If-uncalculated specifies what to do if a feature is
uncalculated (nil - skip, T - use, :calculate or :compute compute the
feature (i.e. call the :if-needed function(s)). If-undefined specifies
what to do if the feature is undefined (nil - skip, T - use, :calculate or
:compute - error). If-getting specifies whether to call the :if-getting
function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(tss-difference! (make-tss path) set-description :if-uncalculated
if-uncalculated :if-getting if-getting :if-undefined
if-undefined))
(defstruct tss-extents
(minrow 0 :type integer)
(mincol 0 :type integer)
(maxrow 0 :type integer)
(maxcol 0 :type integer)
)
(setf (documentation 'make-tss-extents 'function)
"MAKE-TSS-EXTENTS &KEY (minrow 0) (mincol 0) (maxrow 0) (maxcol 0) -
Make a TSS-Extents structure. Used in the various TSS-xxx functions to
choose tokens within a specific spacial range.")
(defstruct range
(min 0 :type number)
(max 0 :type number)
(feature "" :type string)
(circular-p nil)
)
(setf (documentation 'make-range 'function)
"MAKE-RANGE &KEY (min 0) (max 0) (feature \"\") (circular-p nil) -
Make a Range stucture. Used in the various TSS-xxx functions to choose
tokens with a feature values in a selected range. Circluar-p is used
to indicate a circular feature or to select a complementary range.")
(defstruct predicate
(function #'(lambda (&rest ignore) (declare (ignore ignore)) nil))
(features nil :type list))
(setf (documentation 'make-predicate 'function)
"MAKE-PREDICATE &KEY (function #'(lambda (frame token-index &rest featurevalues)
&body code))
(features nil) -
Make a Predicate structure. Used in the various TSS-xxx functions to choose
tokens based on some predicate computed over zero or more feature values.")
(defun tss-intersection! (tss set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-INTERSECTION! tss set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the intersection of the TSS described by tss and the TSS described
by set-description. This function *destructively* modifies its first argument.
If-uncalculated specifies what to do if a feature is uncalculated (nil - skip,
T - use, :calculate or :compute compute the feature (i.e. call the :if-needed
function(s)). If-undefined specifies what to do if the feature is undefined
(nil - skip, T - use, :calculate or :compute - error). If-getting specifies
whether to call the :if-getting function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "Argument must be a TSS: ~S" tss))
(cond ((typep set-description 'range)
(let ((min (range-min set-description))
(max (range-max set-description))
(circ-p (range-circular-p set-description)))
(tss-intersection!-by-predicate
tss
(if (and circ-p (<= max min))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(or (<= feature-value max)
(>= feature-value min)))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(and (>= feature-value min)
(<= feature-value max)))
)
(list (range-feature set-description))
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'tss-extents)
(let ((mincol (tss-extents-mincol set-description))
(minrow (tss-extents-minrow set-description))
(maxcol (tss-extents-maxcol set-description))
(maxrow (tss-extents-maxrow set-description))
)
(tss-intersection!-by-predicate
tss
#'(lambda (ignore1 ignore2 extents)
(declare (ignore ignore1 ignore2))
(and
(or (<= (minx-of extents) mincol (maxx-of extents))
(<= (minx-of extents) maxcol (maxx-of extents))
(<= mincol (minx-of extents) maxcol))
(or (<= (miny-of extents) minrow (maxy-of extents))
(<= (miny-of extents) maxrow (maxy-of extents))
(<= minrow (miny-of extents) maxrow))))
(list "extents")
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'predicate)
(tss-intersection!-by-predicate
tss
(predicate-function set-description)
(predicate-features set-description)
if-uncalculated
if-undefined
if-getting))
;; If we get this far, the second argument must be a TSS or a frame!
;; now we must worry about the different TSS storage formats.
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(frame-token-set-globalp-vector
(handle-frame set-description))
:alu-function #-:EXPLORER :and #+:EXPLORER tv::alu-and))
((and (typep (handle-token-existence-array tss) 'list)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(do* ((evv (frame-token-set-globalp-vector
(handle-frame set-description)))
(result (cons nil (handle-token-existence-array tss)))
(ptr result))
((null (rest ptr))(setf (handle-token-existence-array tss) (rest result)))
(if (= (vvref evv (second ptr)) 0)
(setf (rest ptr) (rest (rest ptr)))
(setf ptr (rest ptr)))
))
((or (not (typep set-description 'handle))
(not (member (handle-type set-description) '(:token-subset :token-sort))))
(error "Not a set description: ~S!" set-description))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(handle-token-existence-array set-description)
:alu-function #-:EXPLORER :and #+:EXPLORER tv::alu-and))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description) 'list))
(do* ((evv (handle-token-existence-array tss))
(result (cons nil (copy-list
(handle-token-existence-array set-description))))
(ptr result))
((null (rest ptr))
(make-null-tss! tss)
(setf (handle-token-existence-array tss) (rest result)))
(if (= (vvref evv (second ptr)) 0)
(setf (rest ptr) (rest (rest ptr)))
(setf ptr (rest ptr)))
)
)
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(do* ((evv (handle-token-existence-array set-description))
(result (cons nil (handle-token-existence-array tss)))
(ptr result))
((null (rest ptr))(setf (handle-token-existence-array tss) (rest result)))
(if (= (vvref evv (second ptr)) 0)
(setf (rest ptr) (rest (rest ptr)))
(setf ptr (rest ptr)))
))
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description) 'list))
(setf (handle-token-existence-array tss)
(nintersection (handle-token-existence-array tss)
(handle-token-existence-array set-description))))
(t (error "(internal error) Attempt to intersect unknown types: ~S and ~S"
tss set-description)))
tss)
(defun tss-union! (tss set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-UNION! tss set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the union of the TSS described by tss and the TSS described
by set-description. This function *destructively* modifies its first argument.
If-uncalculated specifies what to do if a feature is uncalculated (nil - skip,
T - use, :calculate or :compute compute the feature (i.e. call the :if-needed
function(s)). If-undefined specifies what to do if the feature is undefined
(nil - skip, T - use, :calculate or :compute - error). If-getting specifies
whether to call the :if-getting function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "Argument must be a TSS: ~S" tss))
(cond ((typep set-description 'range)
(let ((min (range-min set-description))
(max (range-max set-description))
(circ-p (range-circular-p set-description))
)
(tss-union!-by-predicate
tss
(if (and circ-p (<= max min))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(or (<= feature-value max)
(>= feature-value min)))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(and (>= feature-value min)
(<= feature-value max)))
)
(list (range-feature set-description))
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'tss-extents)
(let ((mincol (tss-extents-mincol set-description))
(minrow (tss-extents-minrow set-description))
(maxcol (tss-extents-maxcol set-description))
(maxrow (tss-extents-maxrow set-description))
)
(tss-union!-by-predicate
tss
#'(lambda (ignore1 ignore2 extents)
(declare (ignore ignore1 ignore2))
(and
(or (<= (minx-of extents) mincol (maxx-of extents))
(<= (minx-of extents) maxcol (maxx-of extents))
(<= mincol (minx-of extents) maxcol))
(or (<= (miny-of extents) minrow (maxy-of extents))
(<= (miny-of extents) maxrow (maxy-of extents))
(<= minrow (miny-of extents) maxrow))))
(list "extents")
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'predicate)
(tss-union!-by-predicate
tss
(predicate-function set-description)
(predicate-features set-description)
if-uncalculated
if-undefined
if-getting))
;; If we get this far, the second argument must be a TSS or a frame!
;; now we must worry about the different TSS storage formats.
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(frame-token-set-globalp-vector
(handle-frame set-description))
:alu-function #-:EXPLORER :ior #+:EXPLORER tv::alu-ior))
((and (typep (handle-token-existence-array tss) 'list)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(let ((old-tss-existence-list (handle-token-existence-array tss)))
(setf (handle-token-existence-array tss)
(deep-copy-evv-2vv-nooptimize (frame-token-set-globalp-vector
(handle-frame set-description))))
(dolist (val old-tss-existence-list)
(setf (vvref (handle-token-existence-array tss) val) 1))))
((or (not (typep set-description 'handle))
(not (member (handle-type set-description) '(:token-subset :token-sort))))
(error "Not a set description: ~S!" set-description))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(handle-token-existence-array set-description)
:alu-function #-:EXPLORER :ior #+:EXPLORER tv::alu-ior))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description) 'list))
(dolist (val (handle-token-existence-array set-description))
(setf (vvref (handle-token-existence-array tss) val) 1)))
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(let ((old-tss-existence-list (handle-token-existence-array tss)))
(setf (handle-token-existence-array tss)
(deep-copy-evv-2vv-nooptimize (handle-token-existence-array
set-description)))
(dolist (val old-tss-existence-list)
(setf (vvref (handle-token-existence-array tss) val) 1))))
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description) 'list))
(setf (handle-token-existence-array tss)
(n-ordered-union (handle-token-existence-array tss)
(handle-token-existence-array set-description))))
(t (error "(internal error) Attempt to union unknown types: ~S and ~S"
tss set-description)))
tss)
(defun n-ordered-union (oset set)
(dolist (elt set)
(setf oset (ordered-insert! elt oset)))
oset)
(defun tss-difference! (tss set-description &KEY (if-uncalculated nil)
(if-getting nil) (if-undefined nil))
"TSS-DIFFERENCE! tss set-description &KEY (:if-uncalculated nil)
(:if-getting nil) (:if-undefined nil) -
Compute the difference of the TSS described by tss and the TSS described
by set-description. This function *destructively* modifies its first argument.
If-uncalculated specifies what to do if a feature is uncalculated (nil - skip,
T - use, :calculate or :compute compute the feature (i.e. call the :if-needed
function(s)). If-undefined specifies what to do if the feature is undefined
(nil - skip, T - use, :calculate or :compute - error). If-getting specifies
whether to call the :if-getting function for a feature. Set-description is one of
A] A TSS or frame,
B] A tss-extents structure (see documentation for isr2::make-tss-extents),
C] A range structure (see documentation for isr2::make-range), or
D] A predicate structure (see documentation for isr2::make-predicate)."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "Argument must be a TSS: ~S" tss))
(cond ((typep set-description 'range)
(let ((min (range-min set-description))
(max (range-max set-description))
(circ-p (range-circular-p set-description))
)
(tss-difference!-by-predicate
tss
(if (and circ-p (<= max min))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(or (<= feature-value max)
(>= feature-value min)))
#'(lambda (ignore1 ignore2 feature-value)
(declare (ignore ignore1 ignore2))
(and (>= feature-value min)
(<= feature-value max)))
)
(list (range-feature set-description))
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'tss-extents)
(let ((mincol (tss-extents-mincol set-description))
(minrow (tss-extents-minrow set-description))
(maxcol (tss-extents-maxcol set-description))
(maxrow (tss-extents-maxrow set-description))
)
(tss-difference!-by-predicate
tss
#'(lambda (ignore1 ignore2 extents)
(declare (ignore ignore1 ignore2))
(and
(or (<= (minx-of extents) mincol (maxx-of extents))
(<= (minx-of extents) maxcol (maxx-of extents))
(<= mincol (minx-of extents) maxcol))
(or (<= (miny-of extents) minrow (maxy-of extents))
(<= (miny-of extents) maxrow (maxy-of extents))
(<= minrow (miny-of extents) maxrow))))
(list "extents")
if-uncalculated
if-undefined
if-getting)))
((typep set-description 'predicate)
(tss-difference!-by-predicate
tss
(predicate-function set-description)
(predicate-features set-description)
if-uncalculated
if-undefined
if-getting))
;; If we get this far, the second argument must be a TSS or a frame!
;; now we must worry about the different TSS storage formats.
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(frame-token-set-globalp-vector
(handle-frame set-description))
:alu-function #-:EXPLORER :andc1 #+:EXPLORER tv::alu-andca))
((and (typep (handle-token-existence-array tss) 'list)
(typep set-description 'handle)
(eq (handle-type set-description) :frame))
(do* ((evv (frame-token-set-globalp-vector
(handle-frame set-description)))
(result (cons nil (handle-token-existence-array tss)))
(ptr result))
((null (rest ptr)) (setf (handle-token-existence-array tss) (rest result)))
(if (= (vvref evv (second ptr)) 1)
(setf (rest ptr) (rest (rest ptr)))
(setf ptr (rest ptr)))))
((or (not (typep set-description 'handle))
(not (member (handle-type set-description) '(:token-subset :token-sort))))
(error "Not a set description: ~S!" set-description))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(bitblt-2index-vectors! (handle-token-existence-array tss)
(handle-token-existence-array set-description)
:alu-function #-:EXPLORER :andc1 #+:EXPLORER tv::alu-andca))
((and (typep (handle-token-existence-array tss) '2index-vector-vector)
(typep (handle-token-existence-array set-description) 'list))
(dolist (val (handle-token-existence-array set-description))
(setf (vvref (handle-token-existence-array tss) val) 0)))
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description)
'2index-vector-vector))
(do* ((evv (handle-token-existence-array set-description))
(result (cons nil (handle-token-existence-array tss)))
(ptr result))
((null (rest ptr)) (setf (handle-token-existence-array tss) (rest result)))
(if (= (vvref evv (second ptr)) 1)
(setf (rest ptr) (rest (rest ptr)))
(setf ptr (rest ptr)))))
((and (typep (handle-token-existence-array tss) 'list)
(typep (handle-token-existence-array set-description) 'list))
(setf (handle-token-existence-array tss)
(nset-difference (handle-token-existence-array tss)
(handle-token-existence-array set-description))))
(t (error "(internal error) Attempt to set-difference unknown types: ~S and ~S"
tss set-description)))
tss)
(defun bitblt-2index-vectors! (2index-vector-1 2index-vector-2
&key (alu-function #-:EXPLORER :iot #+:EXPLORER tv::alu-ior))
"Bitblt two 2index-vectors together. ALU-FUNCTION must be one of: tv:alu-ior [union],
tv:alu-and [intersection] or tv:alu-andca [set-difference]."
(let* ((top-data-1 (2index-vector-vector-data 2index-vector-1))
(top-data-2 (2index-vector-vector-data 2index-vector-2))
;; array length is a function of the fill pointers, not length of the
;; main struct!
(top-level-length (max (fill-pointer top-data-1) (fill-pointer top-data-2))))
(dotimes (ptr top-level-length)
(cond ((and (aref top-data-1 ptr)
(aref top-data-2 ptr))
(let ((overlay-1 (make-array `(1 ,*default-2index-vector-size*)
:element-type 'bit
:displaced-to (2index-bin-vector-data-vector
(aref top-data-1 ptr))))
(overlay-2 (make-array `(1 ,*default-2index-vector-size*)
:element-type 'bit
:displaced-to (2index-bin-vector-data-vector
(aref top-data-2 ptr)))))
(bitblt alu-function *default-2index-vector-size* 1
overlay-2 0 0
overlay-1 0 0)))
((and (not (aref top-data-1 ptr))
(= alu-function #-:EXPLORER :ior #+:EXPLORER tv::alu-ior))
(setf (aref top-data-1 ptr)
(copy-seq (aref top-data-2 ptr))))
((and (not (aref top-data-2 ptr))
(= alu-function #-:EXPLORER :and #+:EXPLORER tv::alu-and))
(setf (aref top-data-1 ptr) nil))
(t nil)))))
(defun deep-copy-evv-2vv-nooptimize (2vv)
(let* ((new-tok-exist (make-2index-vector-vector 0))
(old-outer-vector (2index-vector-vector-data 2vv))
(new-outer-vector (2index-vector-vector-data
new-tok-exist))
(old-fill-pointer (fill-pointer old-outer-vector))
old-inner-vector old-iv
new-inner-vector new-iv
)
(dotimes (ov old-fill-pointer)
(vector-push-extend nil new-outer-vector)
(when (setf old-inner-vector
(aref old-outer-vector ov))
(setf new-inner-vector
(allocate-resource
'2index-bin-vector
(* ov *default-2index-vector-size*))
new-iv (2index-vector-data-vector new-inner-vector)
old-iv (2index-vector-data-vector old-inner-vector)
(aref new-outer-vector ov) new-inner-vector
)
(dotimes (iv *default-2index-vector-size*)
(setf (aref new-iv iv)
(aref old-iv iv)))
)
)
new-tok-exist))
(defun tss-intersection!-by-predicate (tss function features if-calc if-undef
if-get)
(setf features (mapcar #'string-upcase features))
(let ((frame-handle (make-handle :type :frame :frame (handle-frame tss)))
(fhandles (mapcar #'(lambda (feat) (handle (list (frame tss) "<?>" feat)))
features))
)
(for-every-token! (token tss fhandles :error-check t)
(cond ((process-uncalc-features (handle-token token)
fhandles if-calc)
(remove-tokens (list token) tss))
((process-undef-features (handle-token token)
fhandles if-undef)
(remove-tokens (list token) tss))
((apply function frame-handle (handle-token token)
(mapcar #'(lambda (fhand) (fetch-feature (handle-token token)
fhand
if-get))
fhandles))
t)
(t (remove-token! token tss))))
)
tss)
(defun tss-difference!-by-predicate (tss function features if-calc if-undef
if-get)
(setf features (mapcar #'string-upcase features))
(let ((frame-handle (make-handle :type :frame :frame (handle-frame tss)))
(fhandles (mapcar #'(lambda (feat) (handle (list (frame tss) "<?>" feat)))
features))
)
(for-every-token! (token frame-handle fhandles :error-check t)
(cond ((process-uncalc-features (handle-token token)
fhandles if-calc) t)
((process-undef-features (handle-token token)
fhandles if-undef) t)
((apply function frame-handle (handle-token token)
(mapcar #'(lambda (fhand) (fetch-feature (handle-token token)
fhand
if-get))
fhandles))
(remove-token! token tss))))
)
tss)
(defun tss-union!-by-predicate (tss function features if-calc if-undef
if-get)
(setf features (mapcar #'string-upcase features))
(let ((frame-handle (make-handle :type :frame :frame (handle-frame tss)))
(fhandles (mapcar #'(lambda (feat) (handle (list (frame tss) "<?>" feat)))
features))
)
(for-every-token! (token frame-handle fhandles :error-check t)
(cond ((process-uncalc-features (handle-token token)
fhandles if-calc) t)
((process-undef-features (handle-token token)
fhandles if-undef) t)
((apply function frame-handle (handle-token token)
(mapcar #'(lambda (fhand) (fetch-feature (handle-token token)
fhand
if-get))
fhandles))
(add-token! token tss))))
)
tss)
(defun process-uncalc-features (token-index fhandles if-uncalc)
(some #'(lambda (fhand)
(let ((fdescr (handle-fdescr fhand)))
(when (equalp (vvref (fdescr-value fdescr) token-index)
(case (fdescr-type fdescr)
(#.*int* *int-undefined*)
(#.*real* *real-undefined*)
(t *ptr-undefined*)))
(cond ((null if-uncalc) t)
((member if-uncalc '(:calculate :compute))
(value fhand) nil)
(t t))
)
)
)
fhandles)
)
(defun process-undef-features (token-index fhandles if-undef)
(some #'(lambda (fhand)
(let ((fdescr (handle-fdescr fhand)))
(when (equalp (vvref (fdescr-value fdescr) token-index)
(case (fdescr-type fdescr)
(#.*int* *int-undefinable*)
(#.*real* *real-undefinable*)
(t *ptr-undefinable*)))
(cond ((null if-undef) t)
((member if-undef '(:calculate :compute))
(error
"Bad value for :IF-UNDEFINED key: ~S, you probably meant it for :IF-UNCALCULATED" if-undef)
)
(t nil))
)
)
)
fhandles)
)
(defun fetch-feature (token-index fhand if-get)
(if if-get
(value fhand)
(let ((fvalue (vvref (fdescr-value (handle-fdescr fhand)) token-index)))
(cond ((equalp fvalue
(case (fdescr-type (handle-fdescr fhand))
(#.*int* *int-undefined*)
(#.*real* *real-undefined*)
(t *ptr-undefined*)))
:uncalculated)
((equalp fvalue
(case (fdescr-type (handle-fdescr fhand))
(#.*int* *int-undefinable*)
(#.*real* *real-undefinable*)
(t *ptr-undefinable*)))
:undefined)
(t fvalue)))
)
)
(defun tss-mem (token-path tss-path &aux parsed-token-path token-handle more-token-path
tss-handle tss-fval #| parsed-tss-path more-tss-path tss-fdescr |#)
"TSS-MEM token-path tss-path -
Predicate to test if token-path is in TSS defined by tss-path."
(setf parsed-token-path (parse-token-name token-path))
(multiple-value-setq (token-handle more-token-path)
(make-handle-from-parsed-path parsed-token-path))
(unless (and token-handle
(check-terminal-path token-handle more-token-path)
(eq (handle-type token-handle) :token)
(null more-token-path))
(error "~S is not a legitimate path!" token-path))
(cond ((and (handle-p tss-path)
(member (handle-type tss-path) '(:token-subset :token-sort)))
(setf tss-handle tss-path))
(t #|
(setf parsed-tss-path (parse-tss-name tss-path))
(multiple-value-setq (tss-handle more-tss-path)
(make-handle-from-parsed-path parsed-path))
(unless (and tss-handle
(check-terminal-path tss-handle more-tss-path)
(member (handle-type tss-handle)
'(:frame-feature :token-feature))
(eq (fdescr-type (handle-fdescr tss-handle)) *handle*)
(null more-tss-path))
(error "~S is not a legitimate path!" tss-path))
(setf tss-fdescr (handle-fdescr tss-handle))
(if (eq (handle-type tss-handle) :token-feature)
(setf tss-fval (vvref (fdescr-value tss-fdescr)
(handle-token tss-handle)))
(setf tss-fval (fdescr-value tss-fdescr)))
|#
(setf tss-fval (value tss-path))
(unless (and (handle-p tss-fval)
(member (handle-type tss-fval) '(:token-subset
:token-sort)))
(error "~S is not a TSS !" tss-path))
(setf tss-handle tss-fval)))
(unless (eq (handle-frame tss-handle) (handle-frame token-handle))
(error "~S and ~S are from different TS's!" token-path tss-path))
(unless (integerp (handle-token token-handle))
(error "Ambigous token not allowed in tss-mem: ~S" token-handle))
(tss-index-memq (handle-token token-handle)
(handle-token-existence-array tss-handle))
)
(defun tss-mem@ (feature-path tss &aux fval)
"TSS-MEM@ feature-path tss - like TSS-MEM, but gets the value of feature-path
(which must be a token) and uses it as the token to check for membership."
(setf fval (value feature-path))
(unless (and (handle-p fval)
(eq (handle-type fval) :token))
(error "~S (the value of ~S) is not a token handle!" fval feature-path))
(tss-mem fval tss))
(defun add-tokens (token-handle-list tss)
"ADD-TOKENS token-handle-list tss - make a new tss and add the listed tokens to
it."
(add-tokens! token-handle-list (make-tss tss)))
(defun add-tokens! (token-handle-list tss)
"ADD-TOKENS! token-handle-list tss - modify tss to include the listed tokens."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "~S is not a TSS !" tss))
(map nil #'(lambda (token) (add-token! token tss))
token-handle-list)
tss)
(defun add-token (token-handle tss)
"ADD-TOKEN token-handle tss - make a new tss and add the token to it."
(add-token! token-handle (make-tss tss)))
(defun add-token! (token tss &aux parsed-path handle more-path)
"ADD-TOKEN! token tss - modify tss to include the token."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "~S is not a TSS !" tss))
(setf parsed-path (parse-token-name token))
(multiple-value-setq (handle more-path)
(make-handle-from-parsed-path parsed-path))
(unless (and handle
(check-terminal-path handle more-path)
(eq (handle-type handle) :token)
(null more-path))
(error "~S is not a token!" token))
(unless (eq (handle-frame handle) (handle-frame tss))
(error "~S and ~S are not from the same frame!"
token tss))
(if (typep (handle-token-existence-array tss)
'2index-vector-vector)
(setf (vvref (handle-token-existence-array tss)
(handle-token handle)) 1)
(setf (handle-token-existence-array tss)
(ordered-insert! (handle-token handle)
(handle-token-existence-array tss))))
tss)
(defun tss-index-add (new-index tss)
(if (typep (handle-token-existence-array tss)
'2index-vector-vector)
(setf (vvref (handle-token-existence-array tss)
new-index) 1)
(setf (handle-token-existence-array tss)
(ordered-insert! new-index
(handle-token-existence-array tss)))
)
)
(defun ordered-insert! (elt olist)
(cond ((null olist) (list elt))
((< elt (first olist)) (cons elt olist))
((= elt (first olist)) olist)
(t (do ((ol olist (rest ol)))
((or (null (rest ol))
(< elt (second ol)))
(unless (= elt (first ol))
(setf (rest ol)
(cons elt (rest ol))))))
olist)))
(defun remove-tokens (token-handle-list tss)
"REMOVE-TOKENS token-handle-list tss - make a new tss and remove the listed tokens from
it."
(remove-tokens! token-handle-list (make-tss tss)))
(defun remove-tokens! (token-handle-list tss)
"REMOVE-TOKENS! token-handle-list tss - modify tss to not include the listed tokens."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "~S is not a TSS !" tss))
(map nil #'(lambda (token) (remove-token! token tss))
token-handle-list)
tss)
(defun remove-token (token-handle tss)
"REMOVE-TOKEN token-handle tss - make a new tss and remove the token from it."
(remove-token! token-handle (make-tss tss)))
(defun remove-token! (token tss &aux parsed-path handle more-path)
"REMOVE-TOKENS! token-handle tss - modify tss to not include the token."
(unless (and (handle-p tss)
(eq (handle-type tss) :token-subset))
(error "~S is not a TSS !" tss))
(setf parsed-path (parse-token-name token))
(multiple-value-setq (handle more-path)
(make-handle-from-parsed-path parsed-path))
(unless (and handle
(check-terminal-path handle more-path)
(eq (handle-type handle) :token)
(null more-path))
(error "~S is not a token!" token))
(unless (eq (handle-frame handle) (handle-frame tss))
(error "~S and ~S are not from the same frame!"
token tss))
(if (typep (handle-token-existence-array tss)
'2index-vector-vector)
(setf (vvref (handle-token-existence-array tss)
(handle-token handle)) 0)
(setf (handle-token-existence-array tss)
(delete (handle-token handle)
(handle-token-existence-array tss))))
tss)
(defun pick (tss)
"PICK tss - return the next available token in TSS. Returns NIL when the
end of the token subset is encountered. After returning NIL, the next call
to pick will return the first token (i.e. pick will recycle)."
(unless (and (handle-p tss)
(member (handle-type tss) '(:token-subset :token-sort)))
(error "~S is not a TSS!" tss))
(cond ((typep (handle-token-existence-array tss) '2index-vector-vector)
(pick-2vv tss))
(t (pick-tis tss))
)
)
(defun highest-index-of (2vv)
(let ((high-ov (fill-pointer (2index-vector-vector-data 2vv))))
(1- (* high-ov *default-2index-vector-size*)))
)
(defun pick-2vv (tss &aux (evv (handle-token-existence-array tss))
(highest-index (highest-index-of evv)))
(do ((last-index (1+ (or (handle-last-picked tss) -1)) (1+ last-index)))
((or (> last-index highest-index)
(and (= (vvref evv last-index) 1)
(= (vvref (frame-token-set-existence-vector
(handle-frame tss)) last-index) 1)
))
(if (> last-index highest-index)
(setf (handle-last-picked tss) nil)
(progn
(setf (handle-last-picked tss) last-index)
(make-handle :type :token
:frame (handle-frame tss)
:token last-index))))
)
)
(defun pick-tis (tss &aux token-index)
(do ((last-index (rest (or (handle-last-picked tss)
(cons nil (handle-token-existence-array tss))))
(rest last-index)))
((or (null last-index)
(= (vvref (frame-token-set-existence-vector
(handle-frame tss)) (first last-index)) 1))
(setf token-index (first last-index)
(handle-last-picked tss) last-index)
(when token-index
(make-handle :type :token
:frame (handle-frame tss)
:token token-index))
)
)
)
(defun pick-reset! (tss)
"PICK-RESET! tss - reset the pick context for TSS."
(unless (and (handle-p tss)
(member (handle-type tss) '(:token-subset :token-sort)))
(error "Not a sort or TSS: ~S" tss))
(setf (handle-last-picked tss) nil)
tss)
(defun compress (path)
"COMPRESS path - compress the token-indexs in path. WARNING: This
procedure will invalidate all TSS and token-handles associated with this
frame. Use with extreem caution!"
(let* ((frame-handle (%internal-handle path :error-p t :terminal-p t))
(frame-name (isr2:value `(,frame-handle name))))
(unless (and (handle-p frame-handle)
(eq (handle-type frame-handle) :frame))
(error "~S is not a frame!" path))
(let* ((parent (parent frame-handle))
(scratch-frame
(copy-definition frame-handle
(list parent (gensym))))
(new-token 0))
(map nil
#'(lambda (ffpair)
(setf (fdescr-value
(cdr (assoc (first ffpair)
(frame-feature-alist
(handle-frame scratch-frame))
:test #'equalp)))
(fdescr-value (rest ffpair))))
(frame-feature-alist
(handle-frame frame-handle)))
(for-every-token (old-token frame-handle)
(create (list scratch-frame new-token))
(map nil
#'(lambda (fdescr)
(setf (vvref (fdescr-value
(first (member
(fdescr-featurename fdescr)
(frame-token-set-feature-vector
(handle-frame scratch-frame))
:test #'equalp
:key #'fdescr-featurename)))
new-token)
(vvref (fdescr-value fdescr) (token-index-of old-token))))
(frame-token-set-feature-vector
(handle-frame frame-handle)))
(incf new-token))
(map nil
#'(lambda (fdescr)
(do ((i (* (truncate new-token *default-2index-vector-size*)
*default-2index-vector-size*)
(- i *default-2index-vector-size*)))
((< i 0))
(check-and-destroy-empty-block
(fdescr-value fdescr)
i)
))
(frame-token-set-feature-vector
(handle-frame scratch-frame)))
(destroy `(,(isr2:parent frame-handle) ,frame-name))
(destroy `(,(isr2:parent frame-handle) ,frame-name))
(rename scratch-frame frame-name)
)
)
)
(defun tss-sort (tss-path key-feature &key (order :ascending) calculate-p
value-p &aux new-sort fdescr fval tlist scratch-fd-handle)
"TSS-SORT tss-path key-feature &KEY (order :ascending) calculate-p value-p -
make a TSS-SORT object from tss-path and key-feature. Order can be either
:ASCENDING (data values go from lowest to highest) or :DESCENDING (data values
go from highest to lowest). If calculate-p is non-NIL, uncalculated values
are computed and if value-p is non-NIL, then VALUE is used to fetch values.
The default is to simply omit uncalculated values and skip the access functions.
Undefinable values are allways ommited from the sort."
(unless (member order '(:ascending :descending))
(error "Bad sort order: ~S" order))
(setf new-sort (make-null-tss tss-path))
(setf key-feature (string key-feature)
(handle-type new-sort) :token-sort
(handle-feature new-sort) key-feature
(handle-sort-order new-sort) order
(handle-fdescr new-sort) (setf fdescr
(first
(member
key-feature
(frame-token-set-feature-vector
(handle-frame new-sort))
:test #'equalp
:key #'fdescr-featurename)))
scratch-fd-handle (copy-handle new-sort)
(handle-type scratch-fd-handle) :token-feature)
(unless fdescr (error "No such feature defined: ~A for tss-path ~S"
key-feature tss-path))
(unless (member (fdescr-type fdescr) `(,*int* ,*real* ,*string*))
(error "Feature is not of a numeric or string type: ~A for tss-path ~S"
key-feature tss-path))
(for-every-token (token tss-path)
(setf (handle-token scratch-fd-handle) (handle-token token)
fval (if (or value-p calculate-p) (value scratch-fd-handle)
(vvref (fdescr-value fdescr) (handle-token token))))
(unless (or (equalp (case (fdescr-type fdescr)
(#.*int* *int-undefined*)
(#.*real* *real-undefined*)
(#.*string* *ptr-undefined*))
fval)
(equalp (case (fdescr-type fdescr)
(#.*int* *int-undefinable*)
(#.*real* *real-undefinable*)
(#.*string* *ptr-undefinable*))
fval))
(setf tlist (if (eq order :ascending)
(if value-p
(ordered-insert-fv-v-ascending! (handle-token token)
tlist scratch-fd-handle)
(ordered-insert-fv-ascending! (handle-token token)
tlist (fdescr-value fdescr)))
(if value-p
(ordered-insert-fv-v-descending! (handle-token token)
tlist scratch-fd-handle)
(ordered-insert-fv-descending! (handle-token token)
tlist (fdescr-value fdescr))))))
)
(setf (handle-token-existence-array new-sort) tlist)
new-sort)
(defun tss-make-sort (token-list &aux tlist new-sort p)
"TSS-MAKE-SORT token-list -
make a TSS-SORT object from token-list. Token-list must be a list of tokens,
all from the same frame."
(unless (and (consp token-list)
(list-length token-list)
(every #'(lambda (temp)
(and (handle-p temp)
(eq (handle-type temp) :token)
(numberp (handle-token temp))))
token-list))
(error "Not a list of token handles: ~S" token-list))
(setf new-sort (make-null-tss (frame (first token-list))))
(setf (handle-type new-sort) :token-sort
(handle-feature new-sort) nil
(handle-sort-order new-sort) nil
(handle-fdescr new-sort) nil
tlist (list nil)
p tlist)
(dolist (token token-list)
(if (eq (handle-frame new-sort) (handle-frame token))
(setf (rest p) (list (handle-token token))
p (rest p))
(error "Token not in the same frame: ~S not in frame ~S"
token (frame new-sort))))
(setf (handle-token-existence-array new-sort) (rest tlist))
new-sort)
(defun tss-sort-by-predicate (tss-sort predicate &key (stable-sort nil)
&aux new-sort tlist t1-hand t2-hand)
"TSS-SORT-BY-PREDICATE tss-sort predicate &KEY (stable-sort nil) -
Copy and sort a tss-sort using a predicate. If :STABLE-SORT is NIL (the
default), the Common LISP function SORT is used, otherwise the Common LISP
function STABLE-SORT is used. Predicate gets passed two token handles, which
get modified by this function. The predicate should return T iff its first
argument is less-than its second argument."
(unless (and (handle-p tss-sort)
(eq (handle-type tss-sort) :token-sort))
(error "Not a TSS-SORT: ~S" tss-sort))
(setf new-sort (copy-handle tss-sort)
tlist (copy-list (handle-token-existence-array new-sort))
(handle-feature new-sort) nil
(handle-fdescr new-sort) nil
(handle-sort-order new-sort) nil
t1-hand (copy-handle tss-sort)
(handle-type t1-hand) :token
t2-hand (copy-handle tss-sort)
(handle-type t2-hand) :token)
(if stable-sort
(setf tlist (stable-sort tlist #'(lambda (i1 i2)
(setf (handle-token t1-hand) i1
(handle-token t2-hand) i2)
(funcall predicate t1-hand t2-hand))))
(setf tlist (sort tlist #'(lambda (i1 i2)
(setf (handle-token t1-hand) i1
(handle-token t2-hand) i2)
(funcall predicate t1-hand t2-hand))))
)
(setf (handle-token-existence-array new-sort) tlist)
new-sort)
(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun less-p (a b)
(if (numberp a)
(< a b)
(string< a b)))
(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun greater-p (a b)
(if (numberp a)
(> a b)
(string> a b)))
(defun ordered-insert-fv-ascending! (index olist val-vvec &aux fval)
(setf fval (vvref val-vvec index))
(cond #|((member index olist) olist)|#
((null olist) (list index))
((less-p fval (vvref val-vvec (first olist)))
(cons index olist))
(t (do ((ol olist (rest ol)))
((or (null (rest ol))
(less-p fval (vvref val-vvec (second ol))))
(setf (rest ol)
(cons index (rest ol)))))
olist)
)
)
(defun ordered-insert-fv-v-ascending! (index olist fd-handle &aux fval)
(setf (handle-token fd-handle) index
fval (value fd-handle))
(cond #|((member index olist) olist)|#
((null olist) (list index))
((less-p fval (progn (setf (handle-token fd-handle) (first olist))
(value fd-handle)))
(cons index olist))
(t (do ((ol olist (rest ol)))
((or (null (rest ol))
(less-p fval (progn
(setf (handle-token fd-handle) (second ol))
(value fd-handle))))
(setf (rest ol)
(cons index (rest ol)))))
olist))
)
(defun ordered-insert-fv-descending! (index olist val-vvec &aux fval)
(setf fval (vvref val-vvec index))
(cond #|((member index olist) olist)|#
((null olist) (list index))
((greater-p fval (vvref val-vvec (first olist))) (cons index olist))
(t (do ((ol olist (rest ol)))
((or (null (rest ol))
(greater-p fval (vvref val-vvec (second ol))))
(setf (rest ol)
(cons index (rest ol)))))
olist))
)
(defun ordered-insert-fv-v-descending! (index olist fd-handle &aux fval)
(setf (handle-token fd-handle) index
fval (value fd-handle))
(cond #|((member index olist) olist)|#
((null olist) (list index))
((greater-p fval (progn (setf (handle-token fd-handle) (first olist))
(value fd-handle)))
(cons index olist))
(t (do ((ol olist (rest ol)))
((or (null (rest ol))
(greater-p fval (progn
(setf (handle-token fd-handle) (second ol))
(value fd-handle))))
(setf (rest ol)
(cons index (rest ol)))))
olist))
)
(defun tss-sort-key (sort-tss)
"TSS-SORT-KEY sort-tss - returns two values: the sort key (token feature
handle) and the sort order."
(if (and (handle-p sort-tss)
(eq (handle-type sort-tss) :token-sort))
(if (null (handle-feature sort-tss))
(values nil nil)
(values (make-handle :type :token-feature
:frame (handle-frame sort-tss)
:feature (handle-feature sort-tss)
:fdescr (handle-fdescr sort-tss)
:token :?
)
(handle-sort-order sort-tss)))
(error "Not a valid sort: ~S" sort-tss))
)
(defun sort-update! (sort-tss &key calculate-p value-p)
"SORT-UPDATE! sort-tss &KEY calculate-p value-p - resort an existing tss-sort.
Note: this only handles added/droped tokens. If the feature value(s) the sort
is based on have been altered, the sort might not be valid. A new TSS-SORT
handle should be built (i.e. by calling TSS-SORT). If calculate-p is non-NIL,
uncalculated values are computed and if value-p is non-NIL, then VALUE is used
to fetch values. The default is to simply omit uncalculated values and skip the
access functions. Undefinable values are allways ommited from the sort."
(unless (and (handle-p sort-tss)
(eq (handle-type sort-tss) :token-sort))
(error "Not a Sort: ~S" sort-tss))
(when (null (handle-feature sort-tss))
(error "Not a re-sortable sort: ~S" sort-tss))
(when (null (handle-fdescr sort-tss))
(cerror "Fetch feature descriptor, if posible."
"Feature descriptor missing in ~S" sort-tss)
(setf (handle-fdescr sort-tss)
(first (member (handle-feature sort-tss)
(frame-token-set-feature-vector
(handle-frame sort-tss))
:test #'equalp
:key #'fdescr-featurename)))
(when (null (handle-fdescr sort-tss))
(error "Feature descriptor missing in ~S" sort-tss))
)
(let ((tlist (handle-token-existence-array sort-tss))
(scratch-tss (make-tss (frame sort-tss)))
(scratch-fd-handle (copy-handle sort-tss))
)
(setf (handle-type scratch-fd-handle) :token-feature)
(do* ((result (cons nil tlist))
(p result)
(dummy-handle (make-handle :type :token
:frame (handle-frame sort-tss)
:token :?))
(index (second p) (second p)))
((null (rest p)) (setf tlist (rest result)))
(setf (handle-token dummy-handle) index)
(if (tss-mem dummy-handle scratch-tss)
(progn
(remove-tokens! (list dummy-handle) scratch-tss)
(setf p (rest p)))
(progn
(setf (rest p) (rest (rest p))))
)
)
(let ((fdescr (handle-fdescr sort-tss))
(order (handle-sort-order sort-tss))
fval
)
(for-every-token (token scratch-tss)
(setf (handle-token scratch-fd-handle) (handle-token token)
fval (if (or value-p calculate-p) (value scratch-fd-handle)
(vvref (fdescr-value fdescr) (handle-token token))))
(unless (or (equalp (case (fdescr-type fdescr)
(#.*int* *int-undefined*)
(#.*real* *real-undefined*)
(#.*string* *ptr-undefined*))
fval)
(equalp (case (fdescr-type fdescr)
(#.*int* *int-undefinable*)
(#.*real* *real-undefinable*)
(#.*string* *ptr-undefinable*))
fval))
(setf tlist (if (eq order :ascending)
(if value-p
(ordered-insert-fv-v-ascending!
(handle-token token)
tlist scratch-fd-handle)
(ordered-insert-fv-ascending!
(handle-token token)
tlist (fdescr-value fdescr)))
(if value-p
(ordered-insert-fv-v-descending!
(handle-token token)
tlist scratch-fd-handle)
(ordered-insert-fv-descending!
(handle-token token)
tlist (fdescr-value fdescr))))))
)
)
(setf (handle-token-existence-array sort-tss) tlist
(handle-last-picked sort-tss) nil)
)
sort-tss
)
