tree.scm

(define-module myutil.tree
  (use gauche.experimental.ref)
  (use util.match)
  (use srfi-1)
  (use gauche.experimental.lamb)
  (export-all))
(select-module myutil.tree)


;;; primitive-procedure
(define (tree-map fn tree)
  (map (^x  (cond ((list? x) (tree-map fn x))
                        (else (fn x))))
       tree))

(define (tree-for-each fn tree)
  (for-each (^x (cond ((list? x) (tree-for-each fn x))
                      (else (fn x))))
       tree))

(define (tree-fold kons knil tree)
  (fold (^ (x acc) (cond ((list? x) (kons (tree-fold kons knil x) acc))
                         (else (kons x acc))))
        knil tree))

(define (tree-fold-right kons knil tree)
  (fold-right (^ (x acc) (cond ((list? x) (kons (tree-fold-right kons knil x) acc))
                               (else (kons x acc))))
              knil tree))

(define (flatten tree)
  (let loop ((tree tree) (init '()))
    (fold-right (^ (x acc) (if (list? x) (loop x acc) (cons x acc)))
                init tree)))

;;; filter-function
(define (tree-travarse$ branch-fn leaf-fn :optional (default '()))
  (^ (tree)
     (let %travarse ((tree tree))
       (match tree
         [() default]
         [(x . xs) (cond ((list? x) (branch-fn %travarse x xs))
                         (else (leaf-fn %travarse x xs)))]))))

(define (tree-travarse-with-index$ branch-fn leaf-fn :optional (default '()))
  (^ (tree)
     (let %travarse ((tree tree) (d 0))
       (match tree
         [() default]
         [(x . xs) (cond ((list? x) (branch-fn %travarse x xs d))
                         (else (leaf-fn %travarse x xs d)))]))))

;; (define (tree-find p tree)
;;   (match tree
;;     [() #f]
;;     [(x . xs) (cond ((list? x) (or (tree-find p x) (tree-find p xs)))
;;                     (else (or (and (p x) x) (tree-find p xs))))]))

(define (tree-find p tree)
  ((tree-travarse$ (^ (self x xs) (or (self x) (self xs)))
                   (^ (self x xs) (or (and (p x) x) (self xs)))
                   #f)
   tree))

;; (define-syntax with-tree-travarse$
;;   (syntax-rules ()
;;     [(_ args tree
;;         branch-fn-body leaf-fn-body default)
;;      ((tree-travarse$ (lambda args branch-fn-body)
;;                       (lambda args leaf-fn-body)
;;                       default)
;;       tree)]))

;; (define (tree-find p tree)
;;   (with-tree-travarse$ (self x xs) tree
;;                        (or (self x) (self xs))
;;                        (or (and (p x) x) (self xs))
;;                         #f))

(define (tree-find-indexes p tree)
  ((tree-travarse-with-index$ (^ (self x xs i) 
                                 (or (and-let* ((i* (self x 0)))
                                       (cons i i*))
                                     (self xs (+ i 1))))
                              (^ (self x xs i) (or (and (p x) (list i)) (self xs (+ i 1))))
                              #f)
   tree))

(define (tree-filter p tree)
  ((tree-travarse$ (^ (rec x xs) (cons (rec x) (rec xs)))
                   (^ (rec x xs) (if (p x) (cons x (rec xs)) (rec xs))))
   tree))

(define (tree-flat-filter p tree)
  (let loop ((tree tree) (init '()))
    (fold-right (^ (x acc) 
                   (cond ((list? x) (loop x acc))
                         ((p x) (cons x acc))
                         (else acc)))
                init tree)))

(define (tree-remove p tree)
  (tree-filter (complement p) tree))

(define (tree-flat-remove p tree)
  (tree-flat-filter (complement p) tree))

(define (tree-ref tree indexes)
  (fold (^ (i r) (~ r i)) tree indexes))

tree.tmp.scm

(use gauche.experimental.ref)
(use gauche.experimental.lamb)
(add-load-path "..")
(use myutil.tree)
(use gauche.test)

(test-module 'myutil.tree)

(test-start "util.tree")
(define *tree* '(1 (2 (3 (4 (5 5) 4) 3) 2) 1 (((((-6)))))))

(test* "tree-for-each" "1\n2\n3\n4\n5\n5\n4\n3\n2\n1\n-6\n"
       (with-output-to-string (cut tree-for-each print *tree*)))

(test* "tree-map" '(1 (4 (9 (16 (25 25) 16) 9) 4) 1 (((((36))))))
       (tree-map (^x (* x x)) *tree*))

(test* "tree-fold" 24
       (tree-fold + 0 *tree*))

(test* "tree-fold-right" 36
       (tree-fold-right (^ (x y) (+ (abs x) y)) 0 *tree*))

(test* "flatten" '(1 2 3 4 5 5 4 3 2 1 -6)
       (flatten *tree*))

(test* "tree-filter" '(1 ((3 ((5 5)) 3)) 1 ((((())))))
       (tree-filter odd? *tree*))
(test* "tree-flat-filter" '(1 3 5 5 3 1)
       (tree-flat-filter odd? *tree*))
(test* "tree-remove" '(1 ((3 ((5 5)) 3)) 1 ((((())))))
       (tree-remove even? *tree*))
(test* "tree-flat-remove" '(1 3 5 5 3 1)
       (tree-flat-remove even? *tree*))

(test* "tree-find" 2 
       (tree-find even? *tree*))

(test* "tree-find" #f
       (tree-find (^x (= x -10)) *tree*))

(test* "tree-find-indexes" '(3 0 0 0 0 0)
       (tree-find-indexes (^x (= x -6)) *tree*))

(test* "tree-find-indexes " #f
       (tree-find-indexes (^x (= x -7)) *tree*))

(test* "tree-find-indexes " 5
       (eval `(~ *tree* ,@(tree-find-indexes (^x (= x 5)) *tree*))
             (interaction-environment)))

(test* "tree-ref" -6
       (tree-ref *tree* '(3 0 0 0 0 0)))
(test-end)