Advertisement
Guest User

Untitled

a guest
Jun 12th, 2019
138
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.44 KB | None | 0 0
  1. (defstruct (tree-methods)
  2. empty-p leaf-p label children
  3. make-empty make-leaf make-tree)
  4.  
  5. (defmacro define-tree-function (name arguments)
  6. `(defun ,name ,arguments
  7. (funcall (,(intern (format nil "TREE-METHODS-~A"
  8. (if (string= "TREE-" name :end2 5)
  9. (subseq (string name) 5)
  10. name)))
  11. *default-tree-interpretation*)
  12. ,@arguments)))
  13.  
  14. (define-tree-function tree-empty-p (node))
  15. (define-tree-function tree-leaf-p (node))
  16. (define-tree-function tree-label (node))
  17. (define-tree-function tree-children (node))
  18. (define-tree-function tree-make-empty ())
  19. (define-tree-function tree-make-leaf (label))
  20. (define-tree-function tree-make-tree (label children))
  21.  
  22.  
  23. (defparameter *labelless-nary-tree*
  24. (make-tree-methods
  25. :empty-p (function null)
  26. :leaf-p (function atom)
  27. :label (constantly nil)
  28. :children (lambda (node) node)
  29. :make-empty (constantly nil)
  30. :make-leaf (function identity)
  31. :make-tree (lambda (label children)
  32. (declare (ignore label))
  33. children)))
  34.  
  35. (defparameter *default-tree-interpretation* *labelless-nary-tree*)
  36.  
  37. (defun depth (tree)
  38. (cond
  39. ((tree-empty-p tree) 0)
  40. ((tree-leaf-p tree) 1)
  41. (t (1+ (reduce (function max) (tree-children tree)
  42. :key (function depth) :initial-value 0)))))
  43.  
  44. (depth (tree-make-empty)) ; -> 0
  45. (depth (tree-make-leaf 'a)) ; -> 1
  46. (depth (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-leaf 'b) (tree-make-leaf 'c)))) ; -> 2
  47. (depth (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-tree nil (list (tree-make-leaf 'b))) (tree-make-leaf 'c)))) ; -> 3
  48.  
  49.  
  50. (defun flatten-before-deepest (tree)
  51. (case (depth tree)
  52. ((0 1 2) tree)
  53. ((3) (tree-make-tree (tree-label tree)
  54. (mapcan (lambda (child)
  55. (if (tree-leaf-p child)
  56. (list child)
  57. (copy-list (tree-children child))))
  58. (tree-children tree))))
  59. (otherwise (tree-make-tree (tree-label tree)
  60. (mapcar (lambda (child)
  61. (flatten-before-deepest child))
  62. (tree-children tree))))))
  63.  
  64. (flatten-before-deepest (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-tree nil (list (tree-make-leaf 'b))) (tree-make-leaf 'c))))
  65. ;; -> (a b c)
  66.  
  67. (flatten-before-deepest
  68. ;; (a (b (c) d) e ((f g) h i) j)
  69. (tree-make-tree nil (list (tree-make-leaf 'a)
  70. (tree-make-tree nil (list (tree-make-leaf 'b)
  71. (tree-make-tree nil (list (tree-make-leaf 'c)))
  72. (tree-make-leaf 'd)))
  73. (tree-make-leaf 'e)
  74. (tree-make-tree nil (list (tree-make-tree nil (list (tree-make-leaf 'f)
  75. (tree-make-leaf 'g)))
  76. (tree-make-leaf 'h)
  77. (tree-make-leaf 'i)))
  78. (tree-make-leaf 'j))))
  79. ;; --> (a (b c d) e (f g h i) j)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement