;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;  All files in this directory or any subdirectories are   ;;;;;;;;
;;;;;;  copyright 1997, 1998, 1999, 2000, 2002, 2003.           ;;;;;;;;
;;;;;;  by Rafael D. Sorkin.  All rights reserved.              ;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; bibliotek.poset       Time-stamp: < 2003-Dec-06 01:52:25 16337.31913 >
;
;        ===========================================
;        Functions Designed Specifically for Causets
;        ===========================================

;: Some nomenclature 
;  =================
;
;     order = poset = partial order = causet = acyclic transitive digraph
;     preorder = preposet = acyclic irreflexive relation
;     pre-pseudo-order = digraph = (binary) relation 
;     link = hasse-link = irreducible relation
;     chain = linearly ordered subset of an order
;     path = saturated chain (all its links are links of the ambient order)
;     stem = a subset of an order that contains all its elements' pasts
;     past : will be taken wo the *irreflexive* convention
;

;: Roster of functions put together so far
;
;  SEE ALSO functions in { ~/lisp/bibliotek.extras.el }
;
;  past    (returns the "absolute past" of an element)
;
;    setf method also provided for `past'
;
;     (The function `past' defined herein assumes that an element's past is 
;     just its symbol-value.  This can be overridden by redefining `past' and
;     its @ setf-method, but you might then have to recompile every function
;     invoking `past'.)
;
;  past-of (extensions to relative past, past of set, inclusive past)
;
;  prec  (the fundamental order-relation as a predicate)
;
;  jana  (the set of immediate ancestors or "parents")
;
;  stem-p  (is this subset a stem?)
;
;  chain-p  (is this subset a chain?)
;
;  antichain-p  (is this subset an antichain?)
;
;  order-interval/interval  (the interval between two elements)
;
;  future  (of an element rel a set)
;
;  future-of  (extensions to future of a set and inclusive future)
;
;  kesho/watoto (children, not actually defined here, but available elsewhere)
;
;  maximal  (the maximal layer of a suborder)
;
;  minimal  (the minimal layer of a suborder)
;
;  connected-parts (in bibliotek.extras)
;
;  connected-part  (of a poset rel a subset)
;
;  disconnected-part   
;
;  antichains
;
;  midpoints
;
;  compute-links
;
;  compute-levels
;
;  compute-futures
;
;  count-relations
;
;  count-links
;
;  count-chains
;
;  count-paths
;
;  log2-spanning-trees
;
;  log2-spanning-Hasse-trees
;
;  ordering-fraction 
;
;  myrheim-meyer-dim 
;
;  mps-dim (in bibliotek.extras)
;
;  posort-subset/posort/posort-order-upward  (sorts a subset of an order)
;
;  posort-preorder-upward    (sorts a preorder)
;
;  sort-pasts-downward  
;
;  down-sorted-p
;  sorted-p/up-sorted-p
;
;  t-close/t-close-preorder  (transitively closes a preposet, "destructive")
;
;  t-close-digraph/transitively-close-pre-pseudo-order  (allows for cycles)
;
;  transitive-p  (is this relation transitive?)
;
;  n-delete-from-poset  (destructively deletes an elt from an order)
;
;  prepare-substrate (makes a "blank" substrate)
;
;  create-order       (useful for making small posets by hand) 
;  create-relation    (useful for making small relations by hand)
;
;  make-chain
;
;  percolate-unoriginated-order (in bibliotek.extras)
;
;  percolate-originary-poset (in bibliotek.extras)
;
;  make-KR-order     (in bibliotek.extras)
;  make-KR-preorder  (in bibliotek.extras)
;
;  make-test-preposet (in bibliotek.extras)
;
;  poset-subobject/suborder
;
;  copy-poset/copy-order
;
;  order-isomorphism-p (in bibliotek.extras)
;
;  invert-poset-destructively (in bibliotek.extras)
;
;  poset-to-plist
;
;  plist-to-poset
;
;  poset-attributes (with @ setf)  (in bibliotek.extras)
;  set-poset-attributes            (in bibliotek.extras)
;  
;  get-poset-attribute (with @ setf)  (in bibliotek.extras)
;  put-poset-attribute                (in bibliotek.extras)
;
;  ord-find-attribute-holder  (in bibliotek.extras)
; 

;=====================================================================

;: If `in-package' is needed here, see ~/lisp/bibliotek.TCL.l for sample

(provide 'posets)	; GCL once disliked this at end for some reason

;:------------------------------------------------------------------------
;: Define past to be VALUE of symbol, unless past has been defined already
;:------------------------------------------------------------------------  

(unless (fboundp 'past)
 (defalias 'past 'symbol-value)       
 (defsetf past (x) (y) (list 'set x y)))

 ;   Do we need to localize the defsetf here?
 ;   Seems not since it is a macro, whence by the time it is used the
 ;   temporary bindings of x and y will be gone.


;: The functions themselves

(deff past-of (&key 
	        ((:elt x) "" elt-arg)
		((:set S) "" set-arg)
		((:rel R) "" relativize)
		((:inclusive inclusive) nil))
  "\
 The past of an element or a set, intersected with R when supplied.
 (The past of a set means the union of the pasts of its elements.)
 Keyword args  
              :elt  :set  :rel  :inclusive {defaults to nil}
 Usage:
      (past-of :elt x :rel R)
      (past-of :set S :rel R)
      (past-of :elt x :inclusive t), etc.  
 HATARI If interrupted, plists can be ruined!   \
  "
  (&localize x S R inclusive elt-arg set-arg relativize P)
  (&bind-too P)
  (cond 
    (elt-arg 
      (setq P (past x))
      (if inclusive (pushnew x P)))	; see note 3 below
   (set-arg 
     (setq P (union-m%% (mapcar (function past) S)))
     (if inclusive 
	 (setq P (union%% S P))))       ; see note 4 below
   (t 
     (error "Must supply either an element or a set to `past-of'")))
  (if relativize (intersection%% P R) P))
  ;
  ; Comments
  ;
  ; 1. Localization is crucial.
  ;
  ; 2. The roundabout way keywords are put into the "lambda list" is
  ;    necessary if you want to localize them.  Otherwise the keyword name
  ;    itself would get localized => you would have to refer to it by some
  ;    horrible name.
  ;
  ; 3. The use of `pushnew' rather than `push' in elt-arg case is only a
  ;    precaution, it will be needed if we ever switch over to the inclusive
  ;    convention for pasts. 
  ;
  ; 4. Notice that `union%%' preserves order, if it matters.


(deff future (x R &key 
		((:retrieve retrieve) nil)
		((:absolute abs) nil))
  "\
 SYNOPSIS (future x R :retrieve :absolute)
 Returns future(x rel R) == {y in R | x prec y }.
 If :retrieve is absent or nil, we compute the answer directly.
 If :retrieve is non-nil, we retrieve the `future' entry from the plist of x
 and we then intersect it with R unless :absolute is also non-nil
 (so R's value is meaningless for retrieved absolute futures).
 In retrieving, we check that the plist really had a `future' entry, 
 unless  :retrieve = `nocheck'  and  *carefully* = nil.
 HATARI If interrupted, plists can be ruined!           \
  " 
  (&localize x R retrieve abs y F F1)
 ;----------------------------------------------------------------------
 ;/arrange to check for future if so specified or if *carefully* is true
 ;----------------------------------------------------------------------
  (if (and retrieve *carefully*) (setq retrieve 'check)) 
 ;-----------------------------------------------
 ;/either compute or retrieve future as specified
 ;-----------------------------------------------
  (varbind F
   (case retrieve
    ;---------------
    ;/compute future
    ;---------------
     ((nil) (loop for y in R if (prec x y) collect y))
    ;-------------------------
    ;/retrieve it uncautiously
    ;-------------------------
     ((nocheck no-check) (get x 'future))
    ;-----------------------
    ;/retrieve it cautiously
    ;-----------------------
     (otherwise 
      (varbind F1 (Get x 'future t))
      (if (listp F1) F1 (error "future(%s) is missing (or not a list)" x))))) 
 ;-----------------------------------------------------------------------
 ;/now intersect with R if we retrieved, unless absolute future specified
 ;-----------------------------------------------------------------------
  (unless abs (if retrieve (setq F (intersection%% F R))))
 ;---------
 ;/Return F
 ;---------
  F)
 ;
 ; Note. The trick in the 3rd case is that if future was absent then `Get'
 ; will return `t', which is a symbol, not a list.


(deff future-of (&key 
		((:elt x) "" elt-arg)
		((:set S) "" set-arg)
		((:rel R) "" relativized)
		((:inclusive inclusive) nil))
  "\
 The future of an element x or a set S relative to R.
 (The future of a set means the union of the futures of its elements.)
 (x or S should be within R, if not result is undefined.)
 Keyword args are  
                  :elt  :set  :rel :inclusive {defaults to nil}
 Usage:
           (future-of :elt x :rel R)
           (future-of :set S :rel R)
	   (future-of :elt x :inclusive t)  , etc. 
 HATARI If interrupted, plists can be ruined!           \
  "
  (unless relativized (error "Must supply R to `future-of'"))
  (&localize x S R elt-arg set-arg relativized inclusive F)
  (&bind-too F)
  (cond 
    (elt-arg 
      (setq F (future x R))
      (if inclusive (pushnew x F) F))
    (set-arg 
     (setq F (union-m%% (image on S of (future $ R))))
     (if inclusive (setq F (union%% S F)) F))
    (t (error "Must supply either an element or a set to `future-of'"))))
   ; 
   ;
   ; See notes for `past-of'
   ;
   ; A new version is being developed


(deff order-interval (x y &key ((:inclusive incl) nil))
  "\
 The order-interval with lower bound x and upper bound y.
 It is exclusive (``order open'') unless the keyword :inclusive is nonnil.\
  "
  (&localize x y incl retrieve I)
  (varbind I (future x (past y)))
  (cond
   ;---------------
   ;/exclusive case
   ;---------------
    ((not incl) I)
   ;---------------
   ;/inclusive case
   ;---------------
    (incl 
      (cond 
        ((eq x y) (list x))
	((prec x y) (append (list x y) I))
	(otherwise nil)))))

(defalias 'interval 'order-interval)


(deff jana (x &key ((:retrieve retrieve) nil)) 
  "\
 Usage:  (jana x)  (jana x :retrieve t)  (jana x :retrieve 'nocheck)
 The argument should be an element of an order.
 We return its ``immediate past'', ie its set of ``parents''.  
 If the keyword arg  :retrieve  is nil then we compute  (jana x) from scratch,
 otherwise we retrieve it from x's plist.  More specifically, 
 if :retrieve is `nocheck' then we retrieve unconditionally, 
 otherwise we check whether a `jana' entry is actually present in x's plist 
 and we declare an error if it is not.
 NB: We rely on the relation `past' being transitive, a preorder won't do.  \
  "
  (&localize x retrieve W)
  (case retrieve
    ((nil) (o maximal past x))
    ((nocheck) (get x 'jana))
    (otherwise 
      (varbind y (Get x 'jana 't))
      (if (listp y) y 
	(error 
	 (tcl-or-elisp
	   "jana(~s) is missing (or not a list)"
	   "jana(%s) is missing (or not a list)")
	 x)))))


(deff prec (x y) 
  "\
 Returns `t' if x precedes y with irreflexive convention (or more generally,
 with whatever convention is embodied in `past').   \
  "
  (&localize x y)
  (if (memq x (past y)) t nil))


(deff stem-p (S)
  "\
 Does this set S of elements include its past? (ie is it a ``partial stem''?)
 If yes then return `t', otherwise return `nil' and place into `*mrv*' some
 element x of S such that past(x) is not a subset of S.
  "
  (&localize S x)
  (loop 
    for x in S
    unless (subsetp%% (past x) S)
    do
    (setq *mrv* x)
    (return nil)
    finally (return t)))
  ;
  ; faster to do as in `poset-to-plist' below?


(deff chain-p (L)
  "\
 Is this set of elements a chain? 
 We assume it is drawn from an order, not a preorder.
 The sorted chain (or whatever) is placed into `*mrv*' as a second return
 value.  \ 
  "
  (&localize L x)
 ;-------------------------------
 ;/first sort the elements upward
 ;-------------------------------
  (setq L (posort-subset L))
  (setq *mrv* L)
 ;------------------------------------------
 ;/then check each element precedes the next
 ;------------------------------------------
  (not
   (loop 
     for x on L 
     while (cdr x)
     unless (prec (car x) (cadr x))
     return t)))


(deff antichain-p (A)
  "\
 The argument should be a subset of an order.  
 We return `t' if it is an antichain, else `nil'.   \
  "
  (&localize A x)
  (loop for x in A if (meetp%% A (past x)) return nil finally (return t)))


(deff prepare-substrate 
        (&key 
	     ((:elts symbols) 'void elts-supplied)
	     ((:N N) 0 N-supplied)
	     ((:anon anon) t) 
	     ((:name jina))
	     ((:labels labels) nil))
  "\
 The possible args (all keywords) are

  :elts = a list containing the symbols to serve as the poset elements
  :N    = the number of elements of the poset to be created
  :anon = t (default) if symbols should be uninterned (``anonymous'')
  :name = a symbol to serve as the name of the new poset 
  :labels = t if collation keys should be installed (indicator: `kfc')

 Specify either :elts or :N but not both (:elts xor :N)
 If :elts is given then :N and :anon are ignored.
 If :N is given then the N elements will be 
   anonymous case: uninterned symbols named 0 1 2 ...
   non-anonymous:  the interned symbols e0 e1 e2 ...
 Further, all pasts will be nil, as will all plists.
 (Exceptions belonging to obsolete features:
   (a) if :name was supplied then it will have been installed as an ``order-
   attribute'', (b) If :labels were requested then each element-symbol will 
   have been given an integer ``key for collation'' as its `kfc' property.)
 We return the new substrate (ie the order itself). 
 BEWARE
   * Don't accidentally use name of poset as one of its elements!!
   * Using a constant list like '(a b c d) as :elts can be dangerous!  \
  "
  (&localize symbols elts-supplied N N-supplied anon jina labels j symbol)
  (&bind-too ) 
 ;-------------------------------------------------
 ;/check that not both elements and N were supplied
 ;-------------------------------------------------
  (if (and elts-supplied N-supplied)
      (error "Can't supply both elements and N to `prepare-substrate'"))
 ;----------------------------------------------------------------------
 ;/create the symbols to comprise the poset (unless they were suppplied) 
 ;----------------------------------------------------------------------
  (unless elts-supplied
    (setq 
     symbols
     (cond 
       (anon
         (loop 
 	   for j from 0 below N collect 
	   (make-symbol 
	    (tcl-or-elisp
	     (format nil "~s" j)
	     (format     "%s" j)))))
       (t 
	 (loop 
  	   for j from 0 below N collect 
	   (intern 
	    (tcl-or-elisp
	     (format nil "E~s" j)
	     (format     "e%s" j))))))))
 ;----------------------------------------------
 ;/set their pasts to nil and erase their plists
 ;----------------------------------------------
  (ewe on symbols of (setf (past $) nil))
  (ewe on symbols of (setf (symbol-plist $) nil))
 ;-------------------------------------------------
 ;/install collation labels if requested (obsolete)
 ;-------------------------------------------------
  (when labels
    (loop 
      for symbol in symbols
      for j from 0 
      do (setf (symbol-plist symbol) (list 'kfc j))))
        ;(setf (symbol-plist symbol) (list 'label (cons jina j))))
 ;--------------------------
 ;/implement name (obsolete)
 ;--------------------------
  (when jina
    (put (car symbols) 'ord-attr (list 'name jina))
    (set jina symbols))
 ;---------------------
 ;/return the substrate
 ;---------------------
  symbols)
 ;
 ; Rationale for offering uninterned symbols as elts:  When the elts are
 ; uninterned symbols, they can never clash with other symbols. 
 ; Also anonymous symbols are more like unlabelled elts.


(deff posort-subset (S)
  "\
 The intended argument is a subset of an order 
 (but not of a preorder, since transitivity is crucial).
 We return a new list of its elements sorted upward.   
 ALIASES  posort, posort-order-upward  \
  "
  (&localize S |ancestors| x y)
 ;----------------------------
 ;/make an anonymous indicator
 ;----------------------------
  (varbind |ancestors| (cons 'number-of 'ancestors))
 ;--------------------------------------
 ;/record numbers of ancestors on plists
 ;--------------------------------------
  (ewe on S of (put $ |ancestors| (o card past $)))
  (prog1
   ;-----------------------------------------
   ;/sort copy of list on number of ancestors
   ;-----------------------------------------
    (sort (copy-list S)
      (lambda (x y) 
	(< 
	  (get x |ancestors|)
	  (get y |ancestors|))))
   ;-------------------
   ;/restore the plists
   ;-------------------
    (ewe on S of (remprop $ |ancestors|))))
  ;
  ; Method is simply to sort on number of ancestors
 
(defalias 'posort 'posort-subset)
(defalias 'posort-order-upward 'posort-subset)

(deff posort-preorder-upward (R)
  "\
 The argument should be the substrate of a preorder. 
 A sorted copy is returned.
 The sorting is nondestructive, except that it installs in the `sort-label'
 slots of the plists of the elements a natural labeling 0 1 2...  
 If desired,these labels can then be used to sort the pasts as well. 
 The algorithm is just that of `t-close' without the modification of the pasts.
  " 
  (&localize R inner-sort S x counter e)
  (varbind counter 0)
 ;------------------------------------------
 ;/ the recursive fcn that does all the work
 ;------------------------------------------
  (fbind inner-sort (S)
    (loop for x in S do
     (unless (get x 'sort-label)
       (when (past x)
	 (inner-sort (past x)))
       (put x 'sort-label counter)
       (incf counter))))
 ;------------------
 ;/ the "outer" part
 ;------------------
  (assert (listp R) nil "Argument to posort-preorder-upward was not a list")
 ;-----------------------
 ;/ erase any sort labels
 ;-----------------------
  (ewe on R of (put $ 'sort-label nil))
 ;-----------------
 ;/ call the sorter
 ;-----------------
  (inner-sort R)
 ;-----------------------------------
 ;/ sort on the sort labels and return
 ;-----------------------------------
  (Sort (copy-list R) '< :key (lambda (e) (get e 'sort-label))))
 ;;
 ;; This sorter could stand a few more tests

 ;; (defalias 'posort-upward 'posort-preorder-upward)


(deff sort-pasts-downward (P)
  "\
 The argument should be an order (not just a preorder, transitivity required).
 The pasts of its elements are (destructively) sorted downward.  \
  "
  (&localize P |ancestors| x)
  (varbind |ancestors| (list 'number-of-ancestors))
  (ewe on P of (put $ |ancestors| (o card past $)))
  (loop for x in P do
   (setf 
     (past x) 
     (Sort (past x) (function >) :key (lambda (x) (get x |ancestors|)))))
  "Pasts sorted downward")
 ;
 ; Actually, it suffices that the argument be a subset of an order.
 ;
 ; The first part is just the same as `posort-subset'
 ;
 ; In TCL the name of `|ancestors|' is really just "ancestors", but it
 ; doesn't matter since it prints mnemonically, as we want.


(deff down-sorted-p (S) 
  "\
 Is this preorder sorted downward? 
 If not, we also stash an out of order pair in `*mrv*'.
 Assumes irreflexive convention.
 This function is NOT designed to work on non-stem subsets of orders or
 preorders (but probably the worst that can occur is an error, rather than a
 false negative).  On the other hand, it should also work -- ie yield `nil' --
 on relations with cycles. 
  "
  (&localize S tail)
  (setq *mrv* nil)
  (loop for tail on (cdr S)
    unless (subsetp%% (o past car tail) (cdr tail))
    do 
    (assert 
     (subsetp%% (o past car tail) S) nil "Non stem given to `down-sorted-p'!")
    (set '*mrv* (list (car (less%% (o past car tail) (cdr tail))) (car tail)))
    and return nil
    finally (return t)))
  ;
  ; To adapt to reflexive convention, change `(cdr tail)' to `tail'
  ; 
  ; It's okay to begin, as we do, with tail=cdr S because the very first case
  ; can never fail (assuming S is a stem or whole preorder)
  ;
  ; For this to work, it would seem to suffice that (cdr S) be a stem.  It's
  ; not actually necessary that S itself be a stem.

(deff sorted-p (S) 
  "\
 Is this preorder (or stem of one) sorted upward? 
 Assumes irreflexive convention.
 See more info with documentation of down-sorted-p  \
  "
  (&localize S)
  (o down-sorted-p reverse S))
 ;
 ; Probably S can be a non-stem as long as all but last element is a stem.

 (defalias 'up-sorted-p 'sorted-p)



(deff maximal (S)
  "\
 Let O be an order (not just a preorder) and S an arbitrary subset of O.
 Then (maximal S) => the set of maximal elements of S.
 (This version maintains the integrity of plists _during_ operation. If this
  is unimportant, consider the faster version `maximal-7'.) 
  " 
  (&localize S iko x y)
 ;----------------------------------------------------------------
 ;/make an anonymous plist marker and associated marking functions
 ;----------------------------------------------------------------
  (vbind iko (cons nil nil))
  (mbind marked (x) 
     `(eq iko (o car symbol-plist ,x)))
  (mbind mark (x) 
     `(setf (symbol-plist ,x) (cons iko (cons iko (symbol-plist ,x)))))
  (mbind unmark (x) 
     `(setf (symbol-plist ,x) (cddr (symbol-plist ,x))))
 ;-----------------------
 ;/mark each element of S
 ;-----------------------
  (ewe of (mark $) on S)
 ;--------------------------------------------------------------------
 ;/unmark all ancestors of (still) marked elements (the working step!)
 ;--------------------------------------------------------------------
  (loop for x in S if (marked x) do
  (loop for y in (past x) if (marked y) do 
  (unmark y)))
 ;------------------------------------------------
 ;/collect the still-marked elts (and unmark them)
 ;------------------------------------------------
  (loop for x in S 
    if (marked x) 
    collect x
    and do (unmark x)))
  ; 
  ; We check that y is marked before unmarking it, not only to protect the elts
  ; of S from double unmarking, but also (in the case where the subset S is not
  ; a stem) to protect the elements of past(S)\S from being "unmarked", when
  ; they were never marked in the first place.

 (defalias 'maximal-of-order 'maximal)


(deff minimal (S)
  " The set of minimal elements of a subset of an order"
  (&localize S $)
  (loop 
   for $ in S
   unless (meetp%% S (past $))
   collect $))
 ;
 ; Idea for a new version is in order/developing/minimal.el 


(deff compute-futures  (C &key ((:record record) nil)) 
  "\
 Let C be an order.  
 For each x in C we put future(x) in the `future' slot of its plist.
 If keyword :record is true we also add `futures' to the `already-computed' 
 attribute of C.  (:record defaults to nil)  \
  " 
  (&localize C record x y)
 ;-------------------------------------------------------------
 ;/initialize all futures to nil and then loop over pairs y < x
 ;-------------------------------------------------------------
  (ewe on C of (put $ 'future nil)) 
  (ewe for x in C of (ewe on (past x) of (push x (get $ 'future))))
 ;------------------------------------------
 ;/record that futures computed if requested
 ;------------------------------------------
  (if record (pushnew 'futures (get-poset-attribute C 'already-computed)))
  "Futures computed and installed")


(deff compute-links (C &key ((:record record) nil))
  "\
 SYNOPSIS  (compute-links C :record [nil])
 The argument should be an order C (not just a preorder).  
 For each x in C, we compute the set of ``parents'' of x and install it
 in the `jana' slot of x's plist.  
 If keyword :record is true we also add `links' to the `already-computed' 
 attribute of C.  \
  "
  (&localize C record)
  (ewe on C of (put $ 'jana (jana $ :retrieve nil)))
  (if record (pushnew 'links (get-poset-attribute C 'already-computed)))
  "Links computed and installed")


(deff transitive-p (R)
  "\
 Is this relation (pre-pseudo-order) R transitive?  
 If not, we put an ``intransitive triple'' in the global stash `*mrv*'.
 NOTE 
 This algorithm is intended primarily for tests, not ``production use''.  
 It is pretty direct (hence reliable), but typically much slower than
 transitive closers like `t-close'.  So if you already have such a closer which
 you trust, then a faster way to test a given preorder P for transitivity is
 probably just to compare it with its transitive closure.  \
  "
  (&localize R culprit x y)
 ;------------------------------------------------------
 ;/is (past past x) a subset of (past x) forall x in R ?
 ;------------------------------------------------------
  (varbind 
    culprit
    (loop 
      for x in R
      unless (subsetp%% (union-m%% (mapcar (function past) (past x))) (past x))
      return x
      finally (return nil)))
 ;----------------------------------------------------------
 ;/if not then find an intransitive triple (x < y < culprit)
 ;----------------------------------------------------------
  (setq *mrv* 
    (when culprit
      (loop for y in (past culprit) thereis
      (loop for x in (past y)
	 unless (prec x culprit) 
	 return (list x y culprit)))))
 ;-----------------------------------
 ;/return t or nil as the case may be
 ;-----------------------------------
  (not culprit))
 ; 
 ; It works simply by checking for each element whether its past contains its
 ; past's past.  This way it's valid for any relation, though possibly
 ; somewhat slower than it could be if designed for preorders alone.
 ;
 ; Could replace the line 
 ;   unless (subsetp%% (union-m%% (mapcar (function past) (past x))) (past x))
 ; with
 ;   unless (subsetp%% (past-of :set (past x)) (past x))


(deff t-close (R)
  "\
 The argument R should be (the substrate of) a preorder (no cycles).
 We transitively close R by adjusting the pasts of its elements. 
 Finally, we return R.
 NOTE  
 If you interrupt this function, some elements can be left with extraneous
 junk in their plists.   \
  " 
  (&localize R S gathered done prop x y z past-x YY ZZ)
  (&bind-too YY ZZ)
 ;--------------------------------------------------------
 ;/prepare two (anonymous) indicators plus marking macros
 ;--------------------------------------------------------
  (varbind gathered (cons nil nil) done (cons nil nil))
  (mbind mark   (x prop) `(put ,x ,prop t))
  (mbind unmark (x prop) `(put ,x ,prop nil))
  (mbind marked (x prop) `(get ,x ,prop))
 ;-------------------------------------------------
 ;/the "inner" recursive fcn that does all the work
 ;-------------------------------------------------
  (fbind inner-close (S)
    (loop 
      for x in S 
      for past-x = (past x)
      unless (or (marked x done) (not past-x)) do
     ;------------------------------------------
     ;/recursively invoke inner-close on past x
     ;------------------------------------------
      (inner-close past-x) 
     ;--------------------------------------------------------------
     ;/the nub of it all: past(x) = past(x) U past(past(x))
     ;
     ;/mark and gather into ZZ the (unmarked) elts of past[past(x)]
     ; (in the following z < y < x)
     ;--------------------------------------------------------------
      (setq ZZ
	(loop for y in past-x unless (marked y gathered)
	  append
	    (loop for z in (past y) unless (marked z gathered)
	      do (mark z gathered) and collect z)))
     ;-----------------------------------------------------------------
     ;/gather the remaining elements of (past x) into YY = (max past x)
     ;-----------------------------------------------------------------
      (setq YY (loop for y in past-x unless (marked y gathered) collect y))
     ;---------------------------------------------------------
     ;/unmark the elements we have just marked (ie those of ZZ)
     ;---------------------------------------------------------
      (ewe on ZZ of (unmark $ gathered))
     ;---------------
     ;/adjust past x
     ;---------------
      (setf (past x) (append YY ZZ)) 
     ;-----------------
     ;/mark x as `done' 
     ;-----------------
      (mark x done)))
 ;---------------------------
 ;/body ("outer part") begins
 ;---------------------------
  (assert (listp R) nil "Argument to `t-close' should be a list")
 ;--------------------------
 ;/call the recursive closer
 ;--------------------------
  (inner-close R)
 ;---------------------------------------------------
 ;/erase the `done' and `gathered' markings and return the substrate 
 ;---------------------------------------------------
  (ewe on R of (remprop $ done))
  (ewe on R of (remprop $ gathered))
  R)
 ;
 ; This is a self-contained version using "marking".
 ; We use totally anonymous plist indicators for this purpose by the way.
 ; Hence our marking cannot interfere with anything else kept on the plist.
 ; A marked plist looks like (... (nil) t ...)
 ;
 ; At the end, all non-minimal elts of R will have been marked `done'.
 ;
 ; For debugging: (varbind gathered (list 'gathered) done (list 'done))

(defalias 't-close-preorder 't-close)


(deff t-close-digraph (R)
  "\
 Replaces an arbitrary relation R by its transitive closure, the relation being
 represented by the operator `past' on R.  The name refers to the fact that a
 relation with substrate S can be thought of as a directed graph with S as
 vertex-set.  (It can can also be termed a ``pre-pseudo-order on S'')  
 VERY SLOW: Use only for cases where cycles might be present.   \
  "  
  (&localize R j reps)
  (varbind j 0 reps (o ceiling log_2 card R))
  (kwa j from 1 to reps
   (ewe on R of
    (setf 
     (past $)
     (union%% (past $) (union-m%% (mapcar (function past) (past $)))))))
  "Transitive closure complete")
  ;
  ; alternate last line (see printout):
  ; (past-of :set (past-of :elt $ :inclusive t))

(defalias 'transitively-close-pre-pseudo-order 't-close-digraph)


(deff count-relations (Q &key ((:record record) nil))
  "\
 The argument Q can be an order or preorder (not a proper subset thereof).
 We count up the relations of Q and return the result R.
 We also record R in Q's attribute plist, if requested by the keyword 
 argument :record .

 BEWARE The counting won't work correctly with a suborder (unless it's a stem),
 since it merely sums the sizes of the pasts without relativizing them to the
 proffered substrate. \
  "
  (&localize Q record R)
  (&bind-too R)
 ;------------------------------------------------------
 ;/count up the relations and record result if requested
 ;------------------------------------------------------
  (setq R (sum (image of (o card past $) on Q)))
  (if record (put-poset-attribute Q 'relations R))
 ;---------------------------
 ;/return number of relations
 ;---------------------------
  R)


(deff count-links (V &key ((:record record) nil))
  "\
 The argument should be an order O (not a subset thereof, not a preorder).
 We count the links of O using `jana' and return the result L.
 Also record L as the `links' attribute of O if requested by `:record'
 (Although an arbitrary subset of an order is not a valid argument, a stem is
 since a stem is an order in its own right.)   \
  "
  (&localize V record L)
  (&bind-too L)
 ;-------------------------------------------------------
 ;/count up the links of V and record result if requested
 ;-------------------------------------------------------
  (setq L (sum (image of (o card jana $) on V))) 
  (if record (put-poset-attribute V 'links L))
 ;-----------------------
 ;/return number of links
 ;-----------------------
  L)


(deff count-chains (P)
  "\
 The argument should be an entire order P (not a subset of one).
 For each element x of P we compute the number of chains arriving at x 
 (including the singleton chain {x}) and we install the result in x:chains.
 Instead of returning a value as such, we return an advisory statement. 
 ELISP WARNING To ameliorate the large integer problem we use a cutoff, 
 but it's not foolproof.  \
  "
  (&localize P max-reliable x w)
 ;-----------------------------------------------------------------
 ;/(elisp) maximum reliable result in face of large integer problem
 ;-----------------------------------------------------------------
  (varbind max-reliable (/ most-positive-fixnum 64))
 ;-------------------
 ;/sort elements of P
 ;-------------------
  (setq P (posort-order-upward P))
 ;---------------------------
 ;/recursively count chains
 ;---------------------------
  (loop 
    for x in P
    do (put x 'chains (1+ (sum (image on (past x) of (get $ 'chains))))))
 ;--------------------------------------
 ;/(elisp) check whether too many chains 
 ;--------------------------------------
  (when (and P *elisp*)
    (varbind w (sup (image of (get $ 'chains) on P)))
    (if (> w max-reliable)
	(error "too many chains counted to be reliable: %s" w)))
 ;---------------
 ;/return comment
 ;---------------
  "Chains counted and their numbers installed.")
  ;
  ; COMMENTS  
  ;  Using floats for elisp would be more foolproof than our check.
  ;  Sorting is slightly wasteful if already sorted.
 

(deff count-paths (P)
  "\
 The argument should be an entire order P (not a subset of one).
 For each element x of P we compute the number of paths arriving at x 
 (including the singleton path {x} when there is one) and we install the 
 result in x:paths. 
 Instead of returning a value as such, we return an advisory statement. 
 ELISP WARNING To ameliorate the large integer problem we use a cutoff, 
 but it's not foolproof.  \
  "
  (&localize P max-reliable x w)
 ;----------------------------------------------------------
 ;/(elisp) maximum reliable result in face of roundoff error
 ;----------------------------------------------------------
  (varbind max-reliable (/ most-positive-fixnum 64))
 ;---------------
 ;/sort elements 
 ;---------------
  (setq P (posort-order-upward P))
 ;-----------------------------------------------------------
 ;/prepare for the recursion (1 path to each minimal element)
 ;-----------------------------------------------------------
  (ewe on (minimal P) of (put $ 'paths 1))
 ;---------------------------------------------------------------
 ;/recursively count paths to the elements in level 1 or higher
 ;---------------------------------------------------------------
  (loop 
    for x in P
    if (past x)
    do (put x 'paths (sum (image on (jana x) of (get $ 'paths)))))
 ;-------------------------------------
 ;/(elisp) check whether too many paths 
 ;-------------------------------------
  (when (and P *elisp*)
    (varbind w  (sup (image of (get $ 'paths) on P)))
    (if (> w max-reliable)
       (error "too many paths counted to be reliable: %s" w)))
 ;---------------
 ;/return comment  
 ;---------------
  "Paths counted and their numbers installed.")
 ;
 ; COMMENTS 
 ;   For elisp, using floats would be more foolproof than our check.
 ;   Sorting is slightly wasteful if already sorted, and
 ;   computing `jana's is still more wasteful if already has been done.


(deff log2-spanning-trees (Q &key ((:record record) nil))
  "\
 This function assumes that its argument Q is the global poset, not some subset
 thereof. If this is not so, must rewrite it to use relative past.  It computes
 and returns log_2 of the number of spanning trees. It also records the answer
 as the `log2-spanning-trees' attribute of Q if the keyword argument :record is
 non-nil.  Notice that if Q is not originary, it has no spanning trees.  \
  "
  (&localize Q record pasts log-trees w)
 ;----------------------
 ;/give up on empty case
 ;----------------------
  (when (null Q) (error "How many trees span the empty order? "))
 ;-----------------------
 ;/get sizes of all pasts
 ;-----------------------
  (varbind pasts (image of (o card past $) on Q))
  (varbind w (member 0 pasts))
 ;------------------------------------------------
 ;/next catches _some_ cases where Q is not a stem
 ;------------------------------------------------
  (assert w nil "Are you sure this is a stem?")
 ;----------------------------------------------------------------
 ;/if Q not originary there are no spanning trees so return log 0
 ;/otherwise add up log_2 of sizes of (nonempty) pasts 
 ;----------------------------------------------------------------
  (varbind log-trees
    (cond
      ((member 0 (cdr w)) -Infinity%)
      (otherwise (sum (mapcar (function log_2) (delete 0 pasts))))))
 ;-----------------------------------------------------------------
 ;/return result after installing it in attribute list if requested
 ;-----------------------------------------------------------------
  (if record (put-poset-attribute Q 'log2-spanning-trees log-trees))
  log-trees)
 ;
 ; We currently don't handle the empty order.  What do we want the answer
 ; to be in this case?  Should there be 1 tree or none?


(deff log2-spanning-Hasse-trees (Q &key ((:record record) nil))
  "\
 This function assumes that its argument Q is the global poset, not some subset
 thereof. If this is not so, must rewrite it to use relative jana.  We compute
 and return log_2 of the number of spanning Hasse trees (a ``Hasse tree''
 being one all of whose ``branches'' are links of Q, ie its a tree in the Hasse
 graph of Q).
 We also record the answer as the `log2-spanning-Hasse-trees' attribute of Q if
 the keyword argument :record is non-nil.  
 Notice that if Q is not originary, it has no spanning trees at all.  \
  "
  (&localize Q record ayers log-trees w)
 ;----------------------
 ;/give up on empty case
 ;----------------------
  (when (null Q) (error "How many Hasse trees span the empty order? "))
 ;------------------------
 ;/get sizes of all jana's
 ;------------------------
  (varbind ayers (image of (o card jana $) on Q))
  (varbind w (member 0 ayers))
 ;------------------------------------------------
 ;/next catches _some_ cases where Q is not a stem
 ;------------------------------------------------
  (assert w nil "Are you sure this is a stem?")
 ;--------------------------------------------------------------
 ;/add up log_2 of sizes of jana's (or -Infty if Q not originary)
 ;--------------------------------------------------------------
  (varbind log-trees
    (cond
      ((member 0 (cdr w)) -Infinity%)
      (otherwise (sum (mapcar (function log_2) (delete 0 ayers))))))
 ;-----------------------------------------------------------------
 ;/return result after installing it in attribute list if requested
 ;-----------------------------------------------------------------
  (if record (put-poset-attribute Q 'log2-spanning-Hasse-trees log-trees))
  log-trees)
 ;
 ; We currently don't handle the empty order.  What do we want the answer
 ; to be in this case?  Should there be one Hasse-tree or none?


(deff compute-levels (P)
  "\
 The argument should be an order (not a preorder or a suborder).
 We compute the bottom-up levels and install them, using `level' as the plist
 indicator.  The level numbering begins with 0.    \
  "
  (&localize P)
  (ewe 
    on (posort-order-upward P)
    of (put $ 'level 
	 (if 
	   (o not past $) 0
	   (o 1+ sup (image on (past $) of (get $ 'level))))))
  "Levels computed and assigned")
 ;
 ; It's important not to use `map' instead of `ewe', since the former
 ; is absurdly slow in cmucl.


(deff disconnected-part (C A)
  "\
 (disconnected-part C A) => that part of C which is not connected to the
 subset A of C.  When A is empty, this is all of C by definition. 
 We interpret ``connectedness'' _within_ C, not relative to some ambient 
 poset within which C may reside.
 Probably C can be any preorder here, or really any relation at all, 
 it needn't be transitive or acyclic.    \
  "
  (&localize C A)
  (cond
   ((null C) nil)
   ((null A) C)
   (t 
    (disconnected-part
     (less%% C A)
     (less%% (union%% (past-of :set A :rel C) (future-of :set A :rel C)) A)))))
   ;
   ; Another strategy would be to first copy the suborder C, then not have
   ; to relativize pasts and futures to it.


(deff connected-part (whole part)
  "\
 Let A be a subset of C (where C itself may be a suborder of some 
 third order).  Then (connected-part C A) is that part of C which 
 is connected -- within C -- to A.  See the function `disconnected-part' 
 for further explanation.   \
  "
  (&localize whole part)
  (less%% whole (disconnected-part whole part)))


(deff antichains (P)
  " The set of antichains of a poset (including the void antichain)"
  (&localize P x)
  (cond 
   ((null P) (list ()))
   (else
    (varbind x (car P))
    (append
     (antichains (cdr P))
     (image 
      of (cons x $) 
      on (antichains (less%% P (list x) (past x) (future x P))))))))
  ;
  ; Method: Pick an x, every antichain either contains x or not.
  ; If not then it is just an antichain in P\x. 
  ; If yes then it is just x adjoined to an antichain of what remains when
  ; you remove x and all related elements from P.
  ;
  ; Improvement?: could compute futures first, would it help?


(LUN     "create-relation" (H P x j)
(defmacro create-relation (&rest H)
  "\
 Example of usage:

      (create-relation  a < b < c   d < c  e < f < g < c)

 We gather the element-symbols a, b, c, etc into a set P and install their
 pasts exactly as specified. (No transitive closure is taken.) 
 Returned is the resulting relation (which for this package means just the set
 of symbols P).  
 (Notice that we do NOT erase the plists of the symbols.)
 This macro is designed to be usable within compiled functions.  \
  "
  `(progn
     (let 
         ((H (quote ,H))
          (P nil)) 
      ;--------------------
      ;/Gather the elements 
      ;--------------------
       (loop 
          for x in H 
          unless (eq '< x) 
          do (setq P (adjoin x P)))
      ;---------------------------------
      ;/Install their pasts as specified
      ;---------------------------------
       ;; (ewe of (setf (past $) nil) on P)    
       (ewe for x in P of (setf (past x) nil))    
       (loop
          for j from 0 below (length H)
          if (eq '< (nth j H))
          do (pushnew 
              (nth (1- j) H)
              (past (nth (1+ j) H))))
      ;-----------------------------------------
      ;/Return list of elts in order encountered
      ;-----------------------------------------
       (reverse P)))))
    ;
    ; The complications are to ensure that the desired side effects of
    ; setting the pasts occur at run time, not at compile time.  (They would
    ; not be needed for interpretive use.) 


(LUN     "create-order" (H P $)
(defmacro create-order (&rest H)
  "\
 This is essentially the same as `create-relation' except that transitive
 closure is taken to get an order.  Therefore the input should be a preorder:
 it should not contain cycles.  (We don't check for mistakes in this.)
 Returned will be (the substrate of) the order.  
 ADVERTENCIA  Here we do erase the plists of all the elements.  \
  "
  `(progn
     (let ((P (create-relation ,@H)))
       (t-close P)
       (ewe for $ in P of (setf (symbol-plist $) nil))
       P))))


(deff n-delete-from-poset (elt order)
  "\
 SYNOPSIS (n-delete-from-poset ELEMENT ORDER)
 The arguments should be an element of an order and the order itself (meaning,
 as always, its substrate).  We DESTRUCTIVELY delete the elt from the order and
 return the new substrate.  
 Comparison is done with `eq' (i.e. the deletion is done with `delq').
 REMEMBER  This function doesn't know about any symbol used to ``name'' the
 poset.  (It's a function like `delq', not a macro like `pop'.)  Hence if `P'
 (say) is the symbolic name of the poset then you have to reset it by hand,
 as in `(setq P (n-delete-from-poset x P))'.    \
  "  
  (&localize elt order y)
  (setq order (delq elt order))
  (loop for y in order do (setf (past y) (delq elt (past y))))
  order)
 ;
 ; Actually the argument needen't be an order.  I think that any relation will
 ; do (as long as it's the whole relation).


(deff poset-subobject (S)
  "\
 The argument S should be a subset of (the substrate of) an order.  
 We return a copy of S carrying the induced suborder, the elements of the
 copy being *uninterned* symbols with names fashioned from the originals.    
 Each new element is ``embedded'' in the original order via the `embed' 
 entry in its plist, moreover an embedding function is placed in *mrv* as 
 a ``second return value''.  
 (Thus we return S as a subobject in the category-theoretic sense.)  \
  " 
  (&localize S S* tmp-ptr x y z counterpart phi)
 ;--------------------------
 ;/make an anonymous pointer
 ;--------------------------
  (varbind tmp-ptr (cons nil nil))
 ;------------------------------------------------------------
 ;/make a new substrate S*, forming symbol names by adding "*"
 ;------------------------------------------------------------
  (varbind S* 
    (loop for x in S 
      collect (make-symbol (concat (symbol-name x) "*"))))
 ;-------------------------------------------------------------------------
 ;/"embed" the new substrate into the old and add temp pointers back to new
 ;-------------------------------------------------------------------------
  (loop 
    for x in S
    for y in S*
    do 
    (put y 'embed x)
    (put x tmp-ptr y))
 ;-------------------
 ;/form the new pasts
 ;-------------------
  (fbind counterpart (x) (get x tmp-ptr))
  (loop for x in S do
    (setf 
     (o past counterpart x)
     (mapcar #'counterpart (past-of :elt x :rel S))))
 ;--------------------
 ;/erase temp pointers
 ;--------------------
  (ewe on S of (remprop $ tmp-ptr))
 ;-------------------------------------
 ;/place an embedding function in *mrv*
 ;-------------------------------------
  (setq *mrv* (lambda (z) (get z 'embed)))
 ;---------------------
 ;/return new substrate
 ;---------------------
  S*)

(defalias 'suborder 'poset-subobject)


(deff copy-poset (P)
  "\
 The argument should be a poset P (a whole poset, NOT a subset).  
 We return an isomorphic copy of P whose elements are UNINTERNED symbols 
 with the SAME NAMES as the originals.  So beware: confusion will reign 
 if you try to refer to the elements of the copy by name!   
 This function should be faster than `poset-subobject'.   \
  " 
  (&localize P Q x y ptr counterpart)
 ;------------------------------------------------
 ;/make a a new substrate and an anonymous pointer
 ;------------------------------------------------
  (varbind 
    Q (image on P of (o make-symbol symbol-name $))
    ptr (cons 'counterpart nil))
 ;------------------------------------
 ;/make each old elt point to its copy
 ;------------------------------------
  (fbind counterpart (x) (get x ptr))
  (loop 
    for x in P
    for y in Q
    do (put x ptr y))
 ;---------------------
 ;/build the new pasts
 ;---------------------
  (ewe 
    for x in P 
    of (setf (o past counterpart x) (mapcar #'counterpart (past x))))
 ;-------------------------------------
 ;/erase temporary pointers from plists
 ;-------------------------------------
  (ewe on P of (remprop $ ptr))
 ;-------------------------
 ;/return the new substrate
 ;-------------------------
  Q)
 ;
 ; This should be faster than previous since it doesn't have to relativize the
 ; pasts 

(defalias 'copy-order 'copy-poset)


(deff midpoints (substrate)
  "\
 The argument should be the substrate of an ENTIRE poset (not a subposet). 
 We return a two-element list (M k), where M is the set of all ``midpoints''
 and k is the corresponding ``half-interval cardinality''.  Here a midpoint is
 basically an element x at which min(|past x|,|future x|) is maximized and k 
 is basically this max-min value, however the story is complicated by the fact
 that the algorithm recognizes ``virtual midpoints''.  (See the function
 definition itself for the whole story.)  The def of midpoint and the notion of
 virtual midpoint both come from thinking of the argument poset as if it were a
 sprinkling of an interval in Minkowski space. 
 NOTES (1) The number k an be either an integer or a half integer. (2) The
 current algorithm chooses candidate midpoints at random, so the order in which
 it lists the ``midpoints'' is not reproducible.  (3) The empty poset is not a
 valid argument to this function.    \
  "
  (&localize 
    substrate 
    midpts maxmin 
    remaining x wakale wazao early late smaller bigger size)
  (&bind-too size)
  (varbind 
   midpts nil
   maxmin -1)
 ;----------------------------------------------------
 ;/process elements one at a time (selecting randomly)
 ;----------------------------------------------------
  (loop 
    with remaining = (copy-list substrate)
    while remaining
    for x = (random-draw remaining)
      ;;    for x = (car remaining) ; alternative to previous line
    for wakale = (past x)
    for wazao =  (future x substrate)
    for early = (card wakale)
    for late =  (card wazao)
    for smaller = (min early late)
    for bigger  = (max early late)    
    do 
   ;---------------------------
   ;/actual vs virtual midpoint
   ;---------------------------
    (setq size (if (= bigger smaller) (+ 1/2 smaller) (1+ smaller)))
   ;-------------------------------------
   ;/is current candidate weakly better?
   ;-------------------------------------
    (cond
      ((> size maxmin) (setq midpts (list x) maxmin size))    
      ((= size maxmin) (push x midpts)))
   ;-----------------------------------------------------------
   ;/set x aside and discard candidates which are no longer viable
   ;-----------------------------------------------------------
    (setq remaining (delq x remaining))
    if (<= early late) do (setq remaining (less%% remaining wakale))
    if (<= late early) do (setq remaining (less%% remaining wazao)))
 ;----------------------------------------------
 ;/return set of midpoints and value of `maxmin'
 ;----------------------------------------------
  (list midpts maxmin)) 
 ;
 ; Here (I think) is the logic behind the definitions of midpoint and maxmin
 ; implicitly made herein.  A midpoint can be either "real" or "virtual".  It
 ; is real if its pasts and futures are exactly equal, otherwise virtual.  In
 ; reckoning the future and past sizes, we count 1/2 of a real midpoint and
 ; none of a virtual one.  For example, the 3-chain a < b < c has a single,
 ; real midpoint b, and in reckoning maxmin we assign half of b to its past and
 ; half to its future, yielding maxmin=1+1/2=3/2.  The 4-chain, a < b < c < d
 ; on the other hand, has a single "virtual midpoint" between b and c, and so
 ; maxmin=2.  Similarly the "Y" order has a virtual midpoint "just above the
 ; junction" and maxmin is again 2.
 ; This scheme is inspired by sprinklings of intervals into Minkowski.  The
 ; virtual midpoint is trying to be a point sprinkled at the true geometrical
 ; midpoint.
 ;
 ; The midpoints we return are never virtual.  Rather, we return the set of
 ; all x which maximize the imputed past and future sizes.  This includes all
 ; real midpoints and at least one further element for each virtual midpoint.
 ; (Such an extra element will always lie a "half link away" from the
 ; corresponding virtual midpoint (ie it would be a Korean "relation 1" to the
 ; virtual midpoint -- a parent or child -- if the latter were made real), as
 ; for example in the Y where we return the element on level 1).


(deff poset-to-plist (P &key ((:retrieve retrieve-jana) nil))
  "\
 The argument must be a whole poset, NOT a subset.
 We convert it into a plist consisting of the elements alternating with 
 their parent-sets (thus we record only the past links, not the full pasts).  
 If the keyword arg :retrieve is non-nil we assume the links have already been
 computed and installed, and we don't bother re-computing them.  \
  "
  (&localize P retrieve-jana ret x)
 ;----------------------------------------------------------------
 ;/possibly check that our argument is (a stem of) an entire order
 ;----------------------------------------------------------------
  (when *carefully*
    (assert (subsetp%% (union-m%% (mapcar #'past P)) P)
      nil "Argument to `poset-to-plist' should be the whole order"))
 ;----------------
 ;/build the plist
 ;----------------
  (varbind ret (if retrieve-jana 'cautiously nil))
  (loop 
    for x in P 
    collect x
    collect (jana x :retrieve ret)))


(deff plist-to-poset (plist &key ((:no-close no-close) nil))
  "\
 Takes a plist of the type created by `poset-to-plist' and returns the
 corresponding order.  
 If keyword arg :no-close is non-nil, then just returns the relation recorded
 in plist, skipping the transitive closure.    
 WARNING The plists of the symbols concerned will be erased.      \
  "
  (&localize plist no-close pair Rw pw R pasts x Y)
  (&bind-too R pasts)
 ;----------------------------------------------------------
 ;/gather the elements into `R' and their pasts into `pasts'
 ;----------------------------------------------------------
  (loop 
    for pair in (plist-to-alist plist)
    collect (car pair) into Rw
    collect (cdr pair) into pw
    finally (setq R Rw pasts pw))
 ;-----------------------------------
 ;/prepare the symbols as a substrate
 ;-----------------------------------
  (prepare-substrate :elts R)
 ;--------------
 ;/set the pasts
 ;--------------
  (loop 
    for x in R
    for Y in pasts
    do (setf (past x) Y))
 ;--------------------------------------------
 ;/transitively close, unless requested not to
 ;--------------------------------------------
  (unless no-close (t-close R))
 ;---------------------------
 ;/return the resulting order
 ;---------------------------
  R)
 ;
 ; NOTES  
 ;  R is the substrate of the order
 ;  Might want to restore the plists too (and have poset-to-plist save them)


(deff ordering-fraction (C)
  "\
 The ordering-fraction, R/{N choose 2}, of a causet (not a suborder). \
  "
  (&localize C N R r)
  (varbind 
    N (card C)
    R (count-relations C))
  (assert (> N 1) nil "Ordering fraction not defined with < 2 elements")
  (/ R (* 1/2 N (1- N))))

(deff myrheim-meyer-dim (I &optional no-copy)
  "\
 The MM dimension of an interval in a causet.
 (Currently we copy the interval before computing its dimension.  If the 
 argument is a whole poset then giving a non-nil optional second argument 
 will speed things up considerably by not making the copy.)   \
  "
  (&localize I no-copy r d N R)
 ;----------------------------------------------------------------
 ;/an internal function to convert R/{N choose 2} to the dimension
 ;----------------------------------------------------------------
  (fbind r-to-mm (r)
    " Converts R/{N choose 2} to the equivalent MM-dimension."
    (if (= 0 r) (return-from r-to-mm Infinity%))
    (solve-monotone
     (lambda (d) 
       (/
	(factorial (* 3/2 d))
	(factorial d)
	(factorial (* 1/2 d))))
     (/ 3/2 r)				
     :ii (list 1 2)
     :tol-x 1e-14
     :tol-y 1e-8))
 ;--------------------------------------------------------------------------
 ;/we copy I here so that R will be correct when I is not the whole causet
 ;--------------------------------------------------------------------------
  (varbind 
    N (card I)
    R (count-relations (if no-copy I (suborder I))))
  (if (< N 2)
   (error "MM dimension not defined for interval of size %d " N))
  (r-to-mm (/ R (* 0.5 N (1- N)))))


(deff make-chain (N &key ((:anon anonymous) t))
  "(make-chain N :anon)

 A chain of N elements, anonymous if :anon = t (the default).
 (The pasts are sorted downward.)
 NOTE  The pasts ``share tissue''. If this is a problem you can copy 
 the poset or (a kluge) apply `t-close'.    \
  "
  (&localize N anonymous S x)
  (varbind S (prepare-substrate :N N :anon anonymous)) 
  (loop for x on (reverse S) do (setf (o past car x) (cdr x)))
  S)


;: End