lf2-survival-stage-generator/lib/peg-tree-utils.scm

(library (peg-tree-utils)
  (export find-in-peg-tree
          find-all-in-peg-tree
          flatten-filter-peg-tree)
  (import
   (except (rnrs base) let-values)
   (only (guile)
         lambda* λ
         error)
   (prefix (logging) log:)
   (prefix (srfi srfi-1) srfi-1:)))


(define rest cdr)


(define find-in-peg-tree
  (lambda* (peg-tree label #:key (label-equal? symbol=?))
    (cond
     [(null? peg-tree) #f]
     [(pair? (srfi-1:first peg-tree))
      (or (find-in-peg-tree (srfi-1:first peg-tree)
                            label
                            #:label-equal? label-equal?)
          (find-in-peg-tree (rest peg-tree)
                            label
                            #:label-equal? label-equal?))]
     [(label-equal? (srfi-1:first peg-tree) label)
      ;;(cadadr peg-tree)
      peg-tree]
     [else
      (find-in-peg-tree (rest peg-tree)
                        label
                        #:label-equal? label-equal?)])))


(define find-all-in-peg-tree
  (lambda* (peg-tree label #:key (label-equal? symbol=?))
    (cond
     [(null? peg-tree) '()]
     [(pair? (srfi-1:first peg-tree))
      (cons (find-all-in-peg-tree (srfi-1:first peg-tree)
                                  label
                                  #:label-equal? label-equal?)
            (find-all-in-peg-tree (rest peg-tree)
                                  label
                                  #:label-equal? label-equal?))]
     ;; found a match
     [(label-equal? (srfi-1:first peg-tree) label)
      peg-tree]
     [else
      (find-all-in-peg-tree (rest peg-tree)
                            label
                            #:label-equal? label-equal?)])))


(define flatten-filter-peg-tree
  (lambda* (peg-tree label #:key (label-equal? symbol=?))
    (cond
     [(null? peg-tree) '()]
     ;; if nested list
     [(pair? (srfi-1:first peg-tree))
      ;; The first element is at least a pair and the rest is also either a pair
      ;; or null: ((?) ?)
      (cond
       ;; Check, if the car of the list is the structure we are looking for,
       ;; take it and append the results from the rest of the peg tree.
       [(label-equal? (srfi-1:first (srfi-1:first peg-tree))
                      label)
        (append (list (srfi-1:first peg-tree))
                (flatten-filter-peg-tree (rest peg-tree)
                                         label
                                         #:label-equal? label-equal?))]
       [else
        ;; If the car of the list is not the structure we are looking for,
        ;; search in it and in the rest of the list.
        (append (flatten-filter-peg-tree (srfi-1:first peg-tree)
                                         label
                                         #:label-equal? label-equal?)
                (flatten-filter-peg-tree (rest peg-tree)
                                         label
                                         #:label-equal? label-equal?))])]
     [else
      ;; If the searched element is not the first element, then search the rest
      ;; of the tree.
      (flatten-filter-peg-tree (rest peg-tree)
                               label
                               #:label-equal? label-equal?)])))