;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; ;;;;;;;; ;;;;;; All files in this directory or any subdirectories are ;;;;;;;; ;;;;;; copyright 1997, 1998, 1999, 2000, 2002, 2003. ;;;;;;;; ;;;;;; by Rafael D. Sorkin. All rights reserved. ;;;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; bibliotek.extras Time-stamp:<2003-Dec-06 02:47:46 16337.35234> ;: The contents of this file are here for temporary convenience, intended ; to go into other biblioteks eventually, as indicated. ;: Roster of functions/macros ; order-isomorphism-p (--> poset) ; ; mps-dim (--> poset) ; ; invert-poset-destructively (--> poset) ; ; make-KR-order (--> poset) ; ; make-KR-preorder (--> poset) ; ; percolate-unoriginated-order (--> poset) ; ; percolate-originary-poset (--> poset) ; ; make-test-preposet (--> poset) ; ; poset-attributes (with @ setf) (--> poset) ; set-poset-attributes ; ; get-poset-attribute (with @ setf) (--> poset) ; put-poset-attribute ; ; ord-find-attribute-holder (--> poset) ; ; connected-parts (--> poset) ; ; lex-less (--> general) ; ; sup-norm (--> general) ; ; bijection-p (--> general) ; ; ; list-plist/print-plist (nicely prints the entries in the plist L) ; (--> general) ; ; prinf (--> general) ; ; print-fully (--> general) ; ; print-list-in-lines ; print-args-in-lines (prints multiple args on multiple lines) ; print-args-as-line (prints multiple args on a single line) ; ppn ppt ppn* ppt* ; ;: Package info needed here? (if so, see bibliotek.TCL for sample) ;: The functions and macros ;:: Various ones (deff connected-parts (P) " The connected components of an order (or preorder might possibly suffice)" (&localize P CP pool x) (loop with CP = nil with pool = P until (not pool) for x = (car pool) do (setq CP (connected-part pool (list x))) collect CP do (setq pool (less%% pool CP)))) (deff lex-less (x y) "\ Lexicographic comparison of two ``trees'' of cons cells with purely numerical leaves. This is a strict ``less-than'', not a ``less-than-or-equal'': it is an irreflexive linear ordering. Rules nil < number < cons numbers compared by usual `<' conses compared lexicographically as ordered pairs \ " (cond ((null y) nil) ((null x) t) ((atom y) (if (atom x) (< x y) nil)) ((atom x) t) ((lex-less (car x) (car y)) t) ((equal (car x) (car y)) (lex-less (cdr x) (cdr y))) (t nil))) (defalias 'lexical-< 'lex-less) (deff make-KR-order (N) "\ SYNOPSIS (make-KR-order N) A randomly generated 3 layer order of the KR type with N (anonymous) elements. NOTE We use here the definition that has every elt of the bottom layer preceding every elt of the top layer. ADVERTENCIA This def differs from that of `make-KR-preorder' ! \ " (&localize N R top-size bottom-size a b bot mid top x y) (varbind top-size (round N 4) bottom-size (round (- N top-size) 3) a bottom-size b (- N top-size) R (prepare-substrate :N N) bot (subseq R 0 a) mid (subseq R a b) top (subseq R b N)) ; (loop for x in bot do (loop for y in mid if (plusp (Random 2)) do (push x (past y)))) ; (loop for x in mid do (loop for y in top if (o plusp Random 2) do (push x (past y)))) ; (loop for x in bot do (loop for y in top do (push x (past y)))) R) (deff make-KR-preorder (N &optional (name 'ThePoset)) "\ ARGUMENTS N &optional (name ThePoset) A randomly generated 3 layer preorder of the KR type with N (anonymous) elements and `name' as symbolic name. NOTE We do NOT impose that every elt of the bottom layer precedes every elt of the top, we just insert random links between ADJACENT layers. ADVERTENCIA This differs from what `make-KR-order' does! NB The result is not an order unless you make it transitive. \ " (&localize N name R top-numb bottom-numb bottom middle top x y) (varbind R (prepare-substrate :name name :N N) top-numb (round N 4) bottom-numb (round (- N top-numb) 3) bottom (subseq R 0 bottom-numb) middle (subseq R bottom-numb (- N top-numb)) top (subseq R (- N top-numb) N)) ; (loop for x in bottom do (loop for y in middle if (= (Random 2) 1) do (push x (past y)))) ; (loop for x in middle do (loop for y in top if (= (Random 2) 1) do (push x (past y)))) ; R) (deff percolate-unoriginated-order (N |p| &key ((:anon anon) t) ((:random-numbers rng) #'Random)) "\ ARGUMENTS (N p :anon :random-numbers) A poset of N elements is generated by ``transitive percolation'' with parameter p and returned. The keyword argument :anon (default = t) says to use anonymous symbols for the poset elements. The argument :random-numbers specifies the random number generator to be used (defaults to the function `Random'). \ " (&localize N |p| anon rng U x y) ;------------------ ;/prepare substrate ;------------------ (varbind U (prepare-substrate :N N :anon anon)) ;-------------------------------- ;/randomly generate the relations ;-------------------------------- (loop for x on U do (loop for y in (cdr x) do (when (< (funcall rng 1.0) |p|) (push (car x) (past y))))) ;--------------------------------------------- ;/take transitive closure and return substrate ;--------------------------------------------- (t-close U) U) (deff percolate-originary-poset (N |p| &key ((:anon anon) t) ((:random-numbers rng) #'Random)) "\ ARGUMENTS (N p :anon :random-numbers) An originary poset of N elements is percolated with parameter p and returned. The keyword argument :anon says to use anonymous symbols (defaults to t). The keyword argument :random-numbers specifies the random number generator to be used (defaults to the function `Random'). \ " (&localize N |p| name anon rng j k x y substrate nimefanya) (&bind-too substrate) ;---------------------------------------------- ;/an auxiliary fcn to "attach the next element" ;---------------------------------------------- (fbind add-elt (k) " Try to add element number k, return `t' if succeed" (vbind nimefanya nil) (loop for j from 0 below k do (when (< (funcall rng 1.0) |p|) (setq nimefanya t) (push (elt substrate j) (past (elt substrate k))))) nimefanya) ;---------------------- ;/prepare the substrate ;---------------------- (setq substrate (prepare-substrate :N N :anon anon)) ;--------------------------- ;/attach elements one by one ;--------------------------- (loop for k from 1 below N do (loop until (add-elt k))) ;--------------------------------------------------- ;/take transitive closure and return resulting order ;--------------------------------------------------- (t-close substrate)) (defalias 'percolate-originary-order 'percolate-originary-poset) (deff make-test-preposet (&key ((:size N)) ((:p p_0))) "\ Both keyword arguments :size and :p must be specified. We ``percolate'' a preorder to use in tests of poset fcns, then shuffle both the substrate AND the individual pasts. We return the (substrate of the) preorder. \ " (&localize N p_0 PS j k x) (&bind-too PS j k) (assert (and p_0 N) nil "Must specify both :size :p") (setq PS (prepare-substrate :N N :anon nil)) ;------------------------- ;/Generate random "bonds" ;------------------------- (kwa j from 0 upto N (kwa k from (1+ j) upto N (when (< (Random 1.0) p_0) (push (nth j PS) (past (nth k PS)))))) ;------------------------------------- ;/Randomly permute substrate and pasts ;------------------------------------- (ewe on PS of (setf (past $) (o shuffle past $))) (setq PS (shuffle PS)) ;------------------------------- ;/Return the substrate ;------------------------------- PS) (defalias 'make-test-preorder 'make-test-preposet) (deff bijection-p (f A B) "\ Is f:A-->B a bijection? The arguments are `f' (a lisp function) and sets `A' and `B'. This ONLY works if A and B are sets, ie lists WITHOUT duplications.\ " (&localize f A B) (when *carefully* (unless (and (menge-p A) (menge-p B)) (error "Argument to `bijection-p' is not a set"))) (and (= (card A) (card B)) (subsetp B (mapcar f A)))) ; ; If these are sets of symbols, we should be using `menge%%' instead of ; `menge-p' and `subsetp%%' instead of `subsetp' ! (deff order-isomorphism-p (phi P Q) "\ SYNOPSIS (order-isomorphism-p phi P Q) Are the orders P and Q isomorphic via the function phi:P-->Q ? (If not then either phi is not a bijection or some pasts disagree. In the latter case, put into *mrv* the first elts whose pasts differ.) (Actually P and Q can be any relations, they needn't be orders.) The argument phi should be a function acceptable to `funcall'. \ " (&localize phi P Q x) (makunbound '*mrv*) (and (bijection-p phi P Q) (loop for x in P unless (equal%% (past (funcall phi x)) (mapcar phi (past x))) do (set '*mrv* (list x (funcall phi x))) (message " Elements x and (phi x) have been placed in *mrv*") and return nil finally (return t)))) ; ; The syntax (set '*mrv* ...) instead of (setq *mrv* ...) is to help refer ; to the global variable, it makes some compilers happier. (defalias 'tonomorphism-p 'order-isomorphism-p) (defalias 'isomorphism-p 'order-isomorphism-p) (deff sup-norm (Y) "\ (sup-norm Y) => maximum absolute value of an element of Y. Here Y can be a single number, a sequence (ie a list or vector) of numbers, or any sequence implied recursively by these. (This includes a matrix if it is implemented as a vector of vectors, but NOT if it is implemented as a true TCL array.) \ " (if *elisp* (assert (o not stringp Y))) (if (numberp Y) (abs Y) (sup (map 'list #'sup-norm Y)))) ; ; Elisp needs the test because it treats a string as a sequence of integers ; and would return without error if given a string as arg. ; ;;; Must rewrite this to evade absurd slowness of `map' in gcl and cmucl! (deff mps-dim (I) "\ The ``midpoint scaling dimension'' of an interval I in a poset. This works by ``dividing I in half at its midpoint'' (see `midpoints'). \ " (if (null I) (error "mps dimension not defined for empty interval")) (log_2 (ratio (card I) (o cadr midpoints suborder I)))) (deff invert-poset-destructively (R) "\ The argument R can actually be any relation R expressed as its ``pasts''. It need not actually be an order. On the other hand R must be the whole relation (ie it must be closed under `past'), because otherwise the pasts of _other_ elts not in R will be corrupted in general. \ " (&localize R x y zamani) ;------------------------------------ ;/make an anonymous plist indicator ;------------------------------------ (varbind zamani (list 'zamani)) ;----------------------------------------------- ;/store existing pasts in plists and empty pasts ;----------------------------------------------- (ewe on R of (put $ zamani (past $))) (ewe on R of (setf (past $) nil)) ;----------------- ;/gather new pasts ;----------------- (loop for x in R do (loop for y in (get x zamani) do (push x (past y)))) ;------------------------------- ;/erase temporarily stored pasts ;------------------------------- (ewe on R of (remprop $ zamani)) ;--------------------- ;/return the substrate ;--------------------- R) ; ; It's important to erase the stored pasts, or else they accumulate because ; each time the plist indicator is new. (defalias 'n-invert-order 'invert-poset-destructively) ;:: Order-attribute stuff (deff ord-find-attribute-holder (order) "\ SYNOPSIS (ord-find-attribute-holder S) The arg S should be a (non-empty) order. We examine its element-symbols, looking for one that contains an `ord-attr' entry in its plist (and this entry should itself be a plist). This is the ``attribute-holder'' for the order S. (Preferably it is (car S), and of course it should be unique.) If we find such an element, we return it, otherwise we make (car S) be the holder. \ " (&localize order void holder y) (assert order nil "Cannot install attributes for empty poset") (varbind void (list "void") holder (find-if (lambda (y) (not (eq void (Get y 'ord-attr void)))) order)) (when (not holder) (setq holder (car order)) (put holder 'ord-attr nil)) holder) ; ; The trickery with `void' is all to avoid false negatives in checking for ; the presence of the ord-attr list. ; ; Logically the "holder" should be the plist entry, not the symbol itself, ; but this "abuse of language" is mandated by eg how `push' works. (deff poset-attributes (order) "\ The attribute plist of the order (if none is found an empty one is created). " (&localize order) (get (ord-find-attribute-holder order) 'ord-attr)) (deff get-poset-attribute (poset attribute) "\ SYNOPSIS (get-poset-attribute poset attribute) Retrieves a poset-attribute, `poset-attributes'. If `poset' has no attribute holder, one will be installed. \ " (&localize poset attribute symbol) (varbind symbol (ord-find-attribute-holder poset)) (getf (get symbol 'ord-attr) attribute)) (deff put-poset-attribute (poset attribute value) "\ Equivalent to (setf (get-poset-attribute @ @) @) If an ``attribute holder'' doesn't exist, one is installed. \ " (&localize poset attribute value symbol) ;-------------------------------------------- ;/retrieve the element holding the attributes ;-------------------------------------------- (varbind symbol (ord-find-attribute-holder poset)) ;--------------------------------------------- ;/install or modify the attribute as specified ;--------------------------------------------- (setf (getf (get symbol 'ord-attr) attribute) value)) (deff set-poset-attributes (order attributes) " Equivalent to (setf (poset-attributes @ @))" (&localize order attributes) (setf (get (ord-find-attribute-holder order) 'ord-attr) attributes)) (defsetf poset-attributes set-poset-attributes) (defsetf get-poset-attribute put-poset-attribute) ;:: Functions devoted to printing/formatting ;; Note: some builtins for printing are: `princ' `prin1' `print' (defun list-plist (L) "\ Nicely prints the entries in the plist L, one pair per line. \ " (cond (L (tcl-or-elisp (princ (format nil "~s ~s ~%" (car L) (cadr L))) (princ (format "%s %s \n" (car L) (cadr L)))) (list-plist (cddr L))) (t " "))) (defalias 'print-plist 'list-plist) (deff print-fully (x) "\ Prints its argument without any length or depth truncation, and with ``gensym notation'' for uninterned symbols. Returns `t' \ " ;------------------------------ ;/suspend all known truncations ;------------------------------ (varbind print-length nil *print-length* nil print-level nil *print-level* nil print-gensym t *print-gensym* t *print-escape* t) (declare (ignore print-length print-level print-gensym)) ;-------- ;/print x ;-------- (print x) ;------------ ;/return `t' ;------------ t) ; ; NOTE The `ignore' declaration is merely to stop compiler warnings ;; Not clear the following functions are very useful (and they'd be of even ;; less use if elisp and TCL used the same `format' conventions) (deff prinf (&rest args) " This is just `princ' with formatting. " (princ (apply #'format args))) (deff print-list-in-lines (L) "\ Prints the elements of a list, each on its own line using `princ' (which ``produces output for humans to read''). The pattern is: (...) Returns nil. " ;---------------------------------------- ;/print opening parenthesis on a new line ;---------------------------------------- (terpri) (princ "(") ;---------------------------------------- ;/print each list element on its own line ;---------------------------------------- (loop for $ in L do (terpri) (princ $)) ;------------------------------------------------------- ;/print closing parenthesis on a new line and return nil ;------------------------------------------------------- (terpri) (princ ")") (terpri) nil) (defun print-args-in-lines (&rest args) "\ Prints multiple arguments, each on its own line using `princ'. Same as `print-list-in-lines' except prints multiple args instead multiple elts of a single list. Returns nil. " (print-list-in-lines args)) (defun print-args-as-line (&rest args) "\ Prints multiple arguments as a single line ``for humans to read''. Each argument is preceded by a space and the whole lot is followed by a single newline. Returns nil. " (loop for $ in args do (princ " ")(princ $) finally (terpri))) ; ; this one seems particularly useless. (defalias 'breakline 'terpri) (deff ppn* (x &optional (digits 3)) "\ SYNOPSIS (ppn* x &optional d) If the number x is integral then just return it, otherwise prettify it with d significant digits and return the result AS A STRING. (d defaults to 3.) Notice that we do not print the result. \ " (cond ((integerp x) x) ((numberp x) (case *lisp-type* ((elisp) (format (format "%%0.%sg" digits) x)) ((gcl) (format nil (format nil "~~,~sG" digits) x)) ((cmucl) (format nil (format nil "~~0,~s,-2G" digits) x)))))) ; ; cmucl prints one extra digit when it chooses the `e' notation, as compared ; to the `f' notation. So to get the full significant digits in the latter ; case, you have to live with one extra in the former! ; ; This gives right results for `G' notation ;; (concatenate 'string "~0," (format nil "~s" (1- digits)) ",-2G") x) ; ; Fails badly for gcl though (deff ppt* (NT &optional (digits 3)) "\ Prettifies a ``numerical tree'' by prettifying its leaves. Returns the prettified tree, does not print it. " (cond ((numberp NT) (ppn* NT digits)) ((consp NT) (cons (ppt* (car NT) digits) (ppt* (cdr NT) digits))) (otherwise NT))) (deff ppn (x &optional (digits 3)) "\ SYNOPSIS (ppn x &optional d) Print a single prettified number (d significant digits, d defaults to 3) " (princ (ppn* x digits)) (princ " ") (if *elisp* t (values))) (deff ppt (NT &optional (digits 3)) "\ SYNOPSIS (ppt tree &optional digits{3}) Prints a prettified ``numerical tree'' using ppn style " (princ (ppt* NT digits)) (princ " ") (if *elisp* t (values))) ;: End