;; clause 8.5.3.5
(define (caar x) (car (car x)) )
(define (cadr x) (list-ref x 1) )
(define (cdar x) (cdr (car x)) )
(define (cddr x) (cdr (cdr x)) )
(define (caaar x) (car (car (car x))) )
(define (caadr x) (car (car (cdr x))) )
(define (cadar x) (car (cdr (car x))) )
(define (caddr x) (list-ref x 2) )
(define (cdaar x) (cdr (car (car x))) )
(define (cdadr x) (cdr (car (cdr x))) )
(define (cddar x) (cdr (cdr (car x))) )
(define (cdddr x) (cdr (cdr (cdr x))) )
(define (caaaar x) (car (car (car (car x)))) )
(define (caaadr x) (car (car (car (cdr x)))) )
(define (caadar x) (car (car (cdr (car x)))) )
(define (cadaar x) (car (cdr (car (car x)))) )
(define (cadadr x) (car (cdr (car (cdr x)))) )
(define (caddar x) (car (cdr (cdr (car x)))) )
(define (cadddr x) (list-ref x 3) )
(define (cdaaar x) (cdr (car (car (car x)))) )
(define (cdaadr x) (cdr (car (car (cdr x)))) )
(define (cdadar x) (cdr (car (cdr (car x)))) )
(define (cddaar x) (cdr (cdr (car (car x)))) )
(define (cddadr x) (cdr (cdr (car (cdr x)))) )
(define (cdddar x) (cdr (cdr (cdr (car x)))) )
(define (cddddr x) (cdr (cdr (cdr (cdr x)))) )
;; clause 8.5.8.4
(define (char>? c1 c2) (char<? c2 c1))
(define (char>=? c1 c2) (char<=? c2 c1))
;; clause 8.5.8.5
(define (__ci-equiv proc)
(lambda (c1 c2)
(proc (char-upcase c1) (char-upcase c2))
)
)
(define char-ci=? (__ci-equiv char=?))
(define char-ci<? (__ci-equiv char<?))
(define char-ci>? (__ci-equiv char>?))
(define char-ci<=? (__ci-equiv char<=?))
(define char-ci>=? (__ci-equiv char>=?))
;; clause 8.5.9.6
(define (__upcase-string s)
(list->string
(map char-upcase
(string->list s)
)
)
)
(define (__ci-string-equiv proc)
(lambda (s1 s2)
(proc (__upcase-string s1) (__upcase-string s2))
)
)
(define (string>? s1 s2) (string<? s2 s1))
(define (string>=? s1 s2) (string<=? s2 s1))
(define string-ci=? (__ci-string-equiv string=?))
(define string-ci<? (__ci-string-equiv string<?))
(define string-ci>? (__ci-string-equiv string>?))
(define string-ci<=? (__ci-string-equiv string<=?))
(define string-ci>=? (__ci-string-equiv string>=?))
;; clause 8.5.10.3
(define (map f #!rest xs)
(let ((map1 (lambda (f xs)
(let loop ((xs xs))
(if (null? xs)
'()
(cons (f (car xs))
(loop (cdr xs))))))))
(cond ((null? xs)
'())
((null? (cdr xs))
(map1 f (car xs)))
(else
(let loop ((xs xs))
(if (null? (car xs))
'()
(cons (apply f (map1 car xs))
(loop (map1 cdr xs)))))))))
;; clause 10.1.1
(define (current-root) (node-property 'grove-root (current-node)))
;; clause 10.2.2
(define (node-list-reduce nl combine init)
(if (node-list-empty? nl)
init
(node-list-reduce (node-list-rest nl)
combine
(combine init (node-list-first nl)))))
(define (node-list-contains? nl snl)
(node-list-reduce nl
(lambda (result i)
(or result
(node-list=? snl i)))
#f))
(define (node-list-remove-duplicates nl)
(node-list-reduce nl
(lambda (result snl)
(if (node-list-contains? result snl)
result
(node-list result snl)))
(empty-node-list)))
(define (reduce list combine init)
(let loop ((result init)
(list list))
(if (null? list)
result
(loop (combine result (car list))
(cdr list)))))
(define (node-list-union #!rest args)
(reduce args
(lambda (nl1 nl2)
(node-list-reduce nl2
(lambda (result snl)
(if (node-list-contains? result
snl)
result
(node-list result snl)))
nl1))
(empty-node-list)))
(define (node-list-intersection #!rest args)
(if (null? args)
(empty-node-list)
(reduce (cdr args)
(lambda (nl1 nl2)
(node-list-reduce nl1
(lambda (result snl)
(if (node-list-contains? nl2 snl)
(node-list result snl)
result))
(empty-node-list)))
(node-list-remove-duplicates (car args)))))
(define (node-list-difference #!rest args)
(if (null? args)
(empty-node-list)
(reduce (cdr args)
(lambda (nl1 nl2)
(node-list-reduce nl1
(lambda (result snl)
(if (node-list-contains? nl2 snl)
result
(node-list result snl)))
(empty-node-list)))
(node-list-remove-duplicates (car args)))))
(define (node-list-symmetric-difference #!rest args)
(if (null? args)
(empty-node-list)
(reduce (cdr args)
(lambda (nl1 nl2)
(node-list-difference (node-list-union nl1 nl2)
(node-list-intersection nl1 nl2)))
(node-list-remove-duplicates (car args)))))
(define (node-list-union-map proc nl)
(node-list-reduce nl
(lambda (result snl)
(node-list-union (proc snl)
result))
(empty-node-list)))
(define (node-list-some? proc nl)
(node-list-reduce nl
(lambda (result snl)
(if (or result (proc snl))
#t
#f))
#f))
(define (node-list-every? proc nl)
(node-list-reduce nl
(lambda (result snl)
(if (and result (proc snl))
#t
#f))
#t))
(define (node-list-filter proc nl)
(node-list-reduce nl
(lambda (result snl)
(if (proc snl)
(node-list result snl)
result))
(empty-node-list)))
(define (node-list->list nl)
(reverse (node-list-reduce nl
(lambda (result snl)
(cons snl result))
'())))
(define (node-list-tail nl k)
(cond
((< k 0) (empty-node-list))
((zero? k) nl)
(else
(node-list-tail (node-list-rest nl) (- k 1)))))
(define (node-list-head nl k)
(if (zero? k)
(empty-node-list)
(node-list (node-list-first nl)
(node-list-head (node-list-rest nl) (- k 1)))))
;; ^^^^^^^
;; missing in standard
(define (node-list-sublist nl i j)
(node-list-head (node-list-tail nl i) (- j i)))
(define (node-list-count nl)
(node-list-length (node-list-remove-duplicates nl)))
(define (node-list-last nl)
(node-list-ref nl
(- (node-list-length nl) 1)))
;; clause 10.2.3
(define (node-list-property prop nl)
(node-list-map (lambda (snl)
(node-property prop snl default: (empty-node-list)))
nl))
(define (origin nl)
(node-list-property 'origin nl))
(define (origin-to-subnode-rel snl)
(node-property 'origin-to-subnode-rel-property-name snl default: #f))
(define (tree-root nl)
(node-list-property 'tree-root nl))
(define (grove-root nl)
(node-list-property 'grove-root nl))
(define (source nl)
(node-list-property 'source nl))
(define (subtree nl)
(node-list-map (lambda (snl)
(node-list snl (subtree (children snl))))
nl))
(define (subgrove nl)
(node-list-map
(lambda (snl)
(node-list snl
(subgrove
(apply node-list
(map (lambda (name)
(node-property name snl))
(node-property 'subnode-property-names
snl))))))
nl))
(define (ancestors nl)
(node-list-map (lambda (snl)
(let loop ((cur (parent snl))
(result (empty-node-list)))
(if (node-list-empty? cur)
result
(loop (parent cur)
(node-list cur result)))))
nl))
(define (grove-root-path nl)
(node-list-map (lambda (snl)
(let loop ((cur (origin snl))
(result (empty-node-list)))
(if (node-list-empty? cur)
result
(loop (origin cur)
(node-list cur result)))))
nl))
(define (rsiblings nl)
(node-list-map (lambda (snl)
(let ((rel (origin-to-subnode-rel snl)))
(if rel
(node-property rel
(origin snl)
default: (empty-node-list))
snl)))
nl))
(define (ipreced nl)
(node-list-map (lambda (snl)
(let loop ((prev (empty-node-list))
(rest (rsiblings snl)))
(cond ((node-list-empty? rest)
(empty-node-list))
((node-list=? (node-list-first rest) snl)
prev)
(else
(loop (node-list-first rest)
(node-list-rest rest))))))
nl))
(define (ifollow nl)
(node-list-map (lambda (snl)
(let loop ((rest (rsiblings snl)))
(cond ((node-list-empty? rest)
(empty-node-list))
((node-list=? (node-list-first rest) snl)
(node-list-first (node-list-rest rest)))
(else
(loop (node-list-rest rest))))))
nl))
(define (grove-before? snl1 snl2)
(let ((sorted
(node-list-intersection (subgrove (grove-root snl1))
(node-list snl1 snl2))))
(and (= (node-list-length sorted) 2)
(node-list=? (node-list-first sorted) snl1))))
(define (sort-in-tree-order nl)
(node-list-intersection (subtree (tree-root nl))
nl))
(define (tree-before? snl1 snl2)
(let ((sorted
(sort-in-tree-order (node-list snl1 snl2))))
(and (= (node-list-length sorted) 2)
(node-list=? (node-list-first sorted) snl1))))
(define (tree-before nl)
(node-list-map (lambda (snl)
(node-list-filter (lambda (x)
(tree-before? x snl))
(subtree (tree-root snl))))
nl))
(define (property-lookup prop snl if-present if-not-present)
(let ((val (node-property prop snl default: #f)))
(cond
(val (if-present val))
((node-property prop snl default: #t) (if-not-present val))
(else (if-present val)))))
(define (select-by-property nl prop proc)
(node-list-filter (lambda (snl)
(let ((val (node-property prop snl default: #f)))
(and (not (node-list? val))
(proc val))))
nl))
(define (select-by-null-property nl prop)
(node-list-filter (lambda (snl)
(let ((val1 (node-property prop snl null: #f))
(val2 (node-property prop snl null: #t)))
(and (not val1) val2)))
nl))
(define (select-by-missing-property nl prop)
(node-list-filter (lambda (snl)
(let ((val1 (node-property prop snl
default: #f
null: #t))
(val2 (node-property prop snl
default: #t
null: #f)))
(and (not val1) val2)))
nl))
;; clause 10.2.5
(define (attribute name nl)
(node-list-map (lambda (snl)
(named-node name (attributes snl)))
nl))
(define (referent nl)
(node-list-property 'referent nl))
(define (q-element pattern #!optional (nl (current-node)))
(select-elements (subgrove nl) pattern))
(define (q-class sym #!optional (nl (current-node)))
(node-list-filter (lambda (snl)
(equal? (node-property 'class-name snl) sym))
(subgrove nl)))
(define (q-sdata string #!optional (nl (current-node)))
(node-list-filter (lambda (snl)
(and (equal? (node-property 'class-name snl) 'sdata)
(equal? (node-property 'system-data snl) string)))
(subgrove nl)))