diff --git a/decode.rkt b/decode.rkt index 54e4bf2..ec51594 100644 --- a/decode.rkt +++ b/decode.rkt @@ -94,7 +94,6 @@ (module+ test - (check-false (scribble:whitespace? (list "\n" " " "\n"))) ; scribble result is too surprising (check-true (whitespace? " ")) (check-false (whitespace? "foo")) (check-false (whitespace? " ")) ; a nonbreaking space diff --git a/template.rkt b/template.rkt index 0f4454a..3f2e71d 100644 --- a/template.rkt +++ b/template.rkt @@ -21,16 +21,17 @@ (set! files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))) (set! map-main (make-tagged-xexpr 'map-main empty (map path->string files))))) -;; todo: restrict this test +;; todo: restrict this test +;; all names must be unique (define/contract (pmap-tree? x) (any/c . -> . boolean?) (tagged-xexpr? x)) -;; recursively processes tree, converting atoms & their parents into xexprs of this shape: -;; '(atom ((parent "parent"))) +;; recursively processes tree, converting map locations & their parents into xexprs of this shape: +;; '(location ((parent "parent"))) (define/contract (add-parents x [parent empty]) ((pmap-tree?) (xexpr-tag?) . ->* . pmap-tree?) - ; disallow main as parent tag + ; disallow map-main as parent tag (when (equal? parent 'map-main) (set! parent empty)) (match x ;; this pattern signifies next level in hierarchy @@ -43,105 +44,130 @@ [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr 'parent (->string parent)))])) (module+ test - (define stt `(map-main "foo" ,(map-topic "one" (map-topic "two" "three")))) - (check-equal? (add-parents stt) + (define test-map `(map-main "foo" ,(map-topic "one" (map-topic "two" "three")))) + (check-equal? (add-parents test-map) '(map-main ((parent "")) (foo ((parent ""))) (one ((parent "")) (two ((parent "one")) (three ((parent "two")))))))) -(define (remove-parents x) - (cond - [(list? x) `(,(car x) ,@(map remove-parents (cddr x)))] +;; remove parents from tree (i.e., just remove attrs) +;; is not the inverse of add-parents, i.e., you do not get back your original input. +(define/contract (remove-parents x) + (pmap-tree? . -> . tagged-xexpr?) + (match x + [(? tagged-xexpr?) (let-values ([(tag attr elements) (break-tagged-xexpr x)]) + (make-tagged-xexpr tag empty (remove-parents elements)))] + [(? list?) (map remove-parents x)] [else x])) +(module+ test + (check-equal? (remove-parents + '(map-main ((parent "")) (foo ((parent ""))) + (one ((parent "")) (two ((parent "one")) (three ((parent "two"))))))) + '(map-main (foo) (one (two (three)))))) +;; todo: what is this for? (define (main->tree main) (add-parents main)) +;; todo: what is this for? to have default input? +(define tree (main->tree map-main)) +;; return the parent of a given name +(define/contract (get-parent element [tree tree]) + (((λ(i) (or (symbol? i) (string? i)))) (pmap-tree?) . ->* . (or/c string? boolean?)) + (and element (let ([result (se-path* `(,(->symbol element) #:parent) tree)]) + (and result (->string result))))) ; se-path* returns #f if nothing found + + +(module+ test + (define test-tree (main->tree test-map)) + (check-equal? (get-parent 'three test-tree) "two") + (check-equal? (get-parent "three" test-tree) "two") + (check-false (get-parent 'fooburger test-tree))) -(define tree (main->tree map-main)) -(define (get-parent x [xexpr tree]) - (if (empty? x) - empty - (let ([result (se-path* `(,(->symbol x) #:parent) xexpr)]) - (if (not result) ; se-path* returns #f if nothing found - empty ; but don't pass #f up through the chain. - (->string result))))) ; algorithm to find children -(define (get-children x [xexpr tree]) - (if (empty? x) - empty - ; find contents of node. - (let ([node-contents (se-path*/list `(,(->symbol x)) xexpr)]) - ; If there are sublists, just take first element - (map (λ(i) (->string (if (list? i) (car i) i))) node-contents)))) +(define/contract (get-children element [tree tree]) + (((λ(i) (or (symbol? i) (string? i)))) (pmap-tree?) . ->* . (or/c list? boolean?)) + ;; find contents of node. + ;; se-path*/list returns '() if nothing found + (and element (let ([children (se-path*/list `(,(->symbol element)) tree)]) + ; If there are sublists, just take first element + (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) + + +(module+ test + (check-equal? (get-children 'one test-tree) (list "two")) + (check-equal? (get-children 'two test-tree) (list "three")) + (check-false (get-children 'three test-tree)) + (check-false (get-children 'fooburger test-tree))) + + +;; todo next ; find all siblings on current level: go up to parent and ask for children -(define (get-all-siblings x [xexpr tree]) - (get-children (get-parent x xexpr) xexpr)) +(define (get-all-siblings x [tree tree]) + (get-children (get-parent x tree) tree)) -(define (get-adjacent-siblings x [xexpr tree]) +(define (get-adjacent-siblings x [tree tree]) (define-values (left right) - (splitf-at (get-all-siblings x xexpr) (λ(y) (not (equal? (->string x) (->string y)))))) + (splitf-at (get-all-siblings x tree) (λ(y) (not (equal? (->string x) (->string y)))))) ; use cdr because right piece includes x itself at front (values left (if (empty? right) empty (cdr right)))) -(define (get-left-siblings x [xexpr tree]) - (define-values (left right) (get-adjacent-siblings x xexpr)) +(define (get-left-siblings x [tree tree]) + (define-values (left right) (get-adjacent-siblings x tree)) left) -(define (get-right-siblings x [xexpr tree]) - (define-values (left right) (get-adjacent-siblings x xexpr)) +(define (get-right-siblings x [tree tree]) + (define-values (left right) (get-adjacent-siblings x tree)) right) -(define (get-left x [xexpr tree]) - (if (empty? (get-left-siblings x xexpr)) +(define (get-left x [tree tree]) + (if (empty? (get-left-siblings x tree)) empty - (last (get-left-siblings x xexpr)))) + (last (get-left-siblings x tree)))) -(define (get-right x [xexpr tree]) - (if (empty? (get-right-siblings x xexpr)) +(define (get-right x [tree tree]) + (if (empty? (get-right-siblings x tree)) empty - (first (get-right-siblings x xexpr)))) + (first (get-right-siblings x tree)))) -(define (make-page-sequence [xexpr tree]) +(define (make-page-sequence [tree tree]) ; use cdr to get rid of body tag at front ; todo: calculate exclusions? - (map ->string (cdr (flatten (remove-parents xexpr))))) + (map ->string (cdr (flatten (remove-parents tree))))) -(define (get-adjacent-pages x [xexpr tree]) +(define (get-adjacent-pages x [tree tree]) (define-values (left right) - (splitf-at (make-page-sequence xexpr) (λ(y) (not (equal? (->string x) (->string y)))))) + (splitf-at (make-page-sequence tree) (λ(y) (not (equal? (->string x) (->string y)))))) ; use cdr because right piece includes x itself at front (values left (if (empty? right) empty (cdr right)))) -(define (get-previous-pages x [xexpr tree]) - (define-values (left right) (get-adjacent-pages x xexpr)) +(define (get-previous-pages x [tree tree]) + (define-values (left right) (get-adjacent-pages x tree)) left) -(define (get-next-pages x [xexpr tree]) - (define-values (left right) (get-adjacent-pages x xexpr)) +(define (get-next-pages x [tree tree]) + (define-values (left right) (get-adjacent-pages x tree)) right) -(define (get-previous x [xexpr tree]) - (if (empty? (get-previous-pages x xexpr)) +(define (get-previous x [tree tree]) + (if (empty? (get-previous-pages x tree)) empty - (last (get-previous-pages x xexpr)))) + (last (get-previous-pages x tree)))) -(define (get-next x [xexpr tree]) - (if (empty? (get-next-pages x xexpr)) +(define (get-next x [tree tree]) + (if (empty? (get-next-pages x tree)) empty - (first (get-next-pages x xexpr)))) - - + (first (get-next-pages x tree)))) diff --git a/tools.rkt b/tools.rkt index 5fb6264..afe91d7 100644 --- a/tools.rkt +++ b/tools.rkt @@ -262,6 +262,7 @@ ) +;; todo: doc this function (define/contract (map-tree proc tree) (procedure? list? . -> . list?) (cond