~aasg/haunted-blog

ref: fef67bdcac88c14b6ac6affe93e290c1a4fb6ee2 haunted-blog/scm/aasg/outline.scm -rwxr-xr-x 1019 bytes
fef67bdc — Aluísio Augusto Silva Gonçalves Render post tags and relayout post lists 9 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
(define-module (aasg outline)
               #:use-module (srfi srfi-1)
               #:use-module (srfi srfi-11)
               #:export (rank-outline))

(define (collect-next-nodes rank-of current-level rest siblings children)
  (if (or (null? rest) (< (rank-of (car rest)) current-level))
      (values rest siblings children)
      (let-values (((r s c) (recurse-outline rank-of rest current-level)))
	(collect-next-nodes rank-of current-level r (append siblings s) (append children c)))))

(define (recurse-outline rank-of lst previous-level)
  (if (null? lst)
      (values '() '() '())
      (let*-values (((node rest) (car+cdr lst))
		    ((rest siblings children) (collect-next-nodes rank-of (rank-of node) rest '() '())))
	(let ((node-outline (cons* (cons node children) siblings)))
	  (if (eqv? (rank-of node) previous-level)
	      (values rest node-outline '())
	      (values rest '() node-outline))))))

(define (rank-outline rank-of lst)
    (let-values (((r s c) (recurse-outline rank-of lst 0))) c))