(define-record-type thread
   (make-thread key props suffix)
   thread?
   (key thread-key)
   (props thread-props) ; props of CURRENT key, cached
   (suffix thread-suffix (setter thread-suffix)))

 (define-record-printer (thread t out)
   (fprintf out "#<thread ~S ~S ~S>"
            (thread-key t)
            (thread-suffix t)
            (thread-props t)))

 (define (get-mtime props)
   (let ((mtime (assq 'mtime props)))
     (if mtime
         (cdr mtime)
         0)))

 (define (get-name props thread make-new-suffix!)
   (string-append
    (epochtime->string (get-mtime props))
    (thread-suffix thread)))

 (define get-sortkey get-mtime)

 (define (choose-next-thread* threads best-so-far)
   (cond
    ((null? threads) best-so-far)
    ((> (get-sortkey (thread-props (car threads)))
        (get-sortkey (thread-props best-so-far)))
     (choose-next-thread* (cdr threads) (car threads)))
    (else
     (choose-next-thread* (cdr threads) best-so-far))))

 (define (choose-next-thread threads)
   (if (pair? threads)
    (choose-next-thread* (cdr threads) (car threads))
    #f))

 (define (merge-thread threads new-thread)
   (cond
    ((null? threads)
     (list new-thread))

    ((equal? (thread-key (car threads))
             (thread-key new-thread))
     (cons
      (make-thread
       (thread-key new-thread)
       (thread-props new-thread)
       #f)
      (cdr threads)))

    (else
     (cons
      (car threads)
      (merge-thread (cdr threads)
                     new-thread)))))

 (define (merge-threads old-threads new-threads)
   (cond
    ((null? new-threads)
     old-threads)
    (else
     (let ((merged-one
            (merge-thread old-threads (car new-threads))))

       (merge-threads
        merged-one
        (cdr new-threads))))))

 ;; A history is a DAG, where each node has properties and a list of parents.
 ;; The properties contain an mtime, which the nodes must be ordered by
 ;; when we "linearize" the graph by folding over it.
 ;; We do this by running a kind of merge algorithm over one or more
 ;; parallel "threads" we are exploring through the DAG, picking the latest
 ;; node at the head of a thread, and replacing that node with its parent(s).
 ;; When we encounter forks in the history chain, we end up with the parent of
 ;; a node we replace already being at the head of another thread - so we
 ;; merge them and make a new thread out of the two of them.
 (define (fold-history* get-parents get-props
                        threads kons knil make-new-suffix!)

   #|find next thread to advance and place it in "t"
      and update threads into "new-threads".

      "update threads" involves removing the next thread
      and replacing it with its parent(s), and then merging any
      duplications caused by that... |#

      (let ((t (choose-next-thread threads)))
        (if
         (not t)
         knil ;; No threads left, so finish.
         (begin
           ;; Not got a suffix yet? Assign one in time
           ;; for it to be output, and for the suffix to
           ;; be passed on to its parents!
           (unless (thread-suffix t)
                   (set! (thread-suffix t) (make-new-suffix!)))

           (let* ((other-threads (delete! t threads))
                 (parent-keys (get-parents (thread-key t)))
                 (t-parents
                  (if (>= (length parent-keys) 2)
                      ;; 2 or more parents, give suffixes
                      (map
                       (lambda (parent-key)
                         (make-thread parent-key
                                      (get-props parent-key)
                                      #f))
                       parent-keys)
                      ;; 0 or 1 parents, no need for new suffixes;
                      ;; inherit from t.
                      (map
                       (lambda (parent-key)
                         (make-thread parent-key
                                      (get-props parent-key)
                                      (thread-suffix t)))
                       parent-keys)))

                 (new-threads (merge-threads
                               other-threads
                               t-parents)))

             (when (= 1 (length new-threads))
                   ;; Down to a single thread?
                   ;; No need for a suffix any more...
                   (set! (thread-suffix (car new-threads)) ""))

             (let ((next-knil
                   (kons (thread-key t)
                         (get-name (thread-props t) t make-new-suffix!)
                         (thread-props t)
                         knil)))
              (fold-history* get-parents get-props
                             new-threads
                             kons next-knil make-new-suffix!)))))))

(define (fold-history** get-parents get-props
                        root kons knil)
  (let ((*suffix-counter* 0))
   (fold-history* get-parents get-props
                  (list (make-thread root (get-props root) ""))
                  kons knil
                  (lambda ()
                    (inc! *suffix-counter*)
                    (sprintf "-~a" *suffix-counter*)))))

 (define (fold-history vault tag-name key type kons knil)
   (receive
    (update! get-parents get-props)
    (case type
      ((snapshot) (values update-snapshot-cache-for-tag!
                          (lambda (key)
                            (get-snapshot-parents vault tag-name key))
                          (lambda (key)
                            (get-snapshot-props vault tag-name key))))
      ((archive) (values update-archive-cache-for-tag!
                         (lambda (key)
                           (get-import-parents vault tag-name key))
                         (lambda (key)
                           (get-import-props vault tag-name key))))
      (else
       (error 'fold-history "Unknown history type" type)))

    (update! vault tag-name)

    (fold-history** get-parents get-props
                    key
                    kons knil)))

Generated by using scpaste at Sun Nov 2 21:46:02 2014. GMT. (original)