Skip to content

Commit ed5cdb1

Browse files
christophejunkechristophejunke
committed
Add Common Lisp solution
Tested with sbcl: $ sbcl --load "$PWD/pure-gf-walk.lisp" --eval "(nested-traversal.pure-gf-walk:test)"
1 parent d6c3fa8 commit ed5cdb1

File tree

1 file changed

+202
-0
lines changed

1 file changed

+202
-0
lines changed

‎common-lisp/pure-gf-walk.lisp

Lines changed: 202 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,202 @@
1+
(defpackage :nested-traversal.pure-gf-walk
2+
(:use :cl)
3+
(:export #:test))
4+
5+
(in-package :nested-traversal.pure-gf-walk)
6+
7+
;;;;
8+
;;;; A purely functional approach, no mutation.
9+
;;;;
10+
;;;; First I define a generic object walker (could be improved) with
11+
;;;; user-provided methods for decomposing and recomposing objects.
12+
;;;;
13+
;;;; Then I define data-structures for input, output (struct
14+
;;;; inheritance), and define methods for decomposing and recomposing
15+
;;;; sections.
16+
;;;;
17+
;;;; Then I define a generic walker function that works on sections
18+
;;;; and lessons structures, to number items based on an environment
19+
;;;; variable that is carried along during tree-walking.
20+
;;;;
21+
22+
;;; A somewhat generic but naive tree walker
23+
;;; ========================================
24+
25+
(defgeneric decompose (object)
26+
(:documentation "list all the object's child objects")
27+
(:method (o)
28+
"no child by default"
29+
nil)
30+
(:method ((list list))
31+
"a list already list all its children"
32+
list))
33+
34+
(defgeneric recompose (object new-children)
35+
(:documentation "given an object and new children, build a new object")
36+
(:method (object (children null))
37+
"for atoms without children, return object unmodified"
38+
object)
39+
(:method ((list list) children)
40+
"if the original object was a list, return the new children list"
41+
children))
42+
43+
(defun walk-tree (tree function &key env)
44+
"Call FUNCTION on TREE and its descendants while carrying an environment ENV.
45+
46+
More precisely, the user-provided FUNCTION must accept at least one
47+
argument, the current object being visited, and an :ENV keyword
48+
argument (the call is made with :ALLOW-OTHER-KEYS T)
49+
50+
FUNCTION must return two values, a new object and the updated
51+
environment. This new object is DECOMPOSE'd to produce a list of
52+
child objects to be processed recursively, which gives a list of
53+
new child objects. They are RECOMPOSE'd with that value to produce
54+
the final tree object."
55+
(flet ((walk (u e) (walk-tree u function :env e))
56+
(visit (u e) (funcall function u :env e :allow-other-keys t)))
57+
;; first, visit object with FUNCTION and ENV
58+
(multiple-value-bind (tree env) (visit tree env)
59+
;; then, decompose into child items and walk recursively
60+
(labels ((fold (env children new-children)
61+
;; fold needs to carry the environment, as well as
62+
;; the new (reversed) list of new-children when
63+
;; processing the input list of children
64+
(if children
65+
(destructuring-bind (c . children) children
66+
(multiple-value-bind (c env) (walk c env)
67+
(fold env children (cons c new-children))))
68+
(let ((children (nreverse new-children)))
69+
;; recompose with tree, return also the
70+
;; updated environment
71+
(values (recompose tree children) env)))))
72+
(fold env (decompose tree) nil)))))
73+
74+
;; For example:
75+
76+
(let ((tree '(a (b c) (d e (f g)))))
77+
(assert (equalp
78+
'("A" ("B" "C") ("D" "E" ("F" "G")))
79+
(walk-tree tree
80+
(lambda (u &key)
81+
(typecase u
82+
(symbol (symbol-name u))
83+
(t u))))))
84+
(multiple-value-bind (new-tree env)
85+
(walk-tree tree
86+
(lambda (u &key env)
87+
(values u
88+
(typecase u
89+
(symbol (cons u env))
90+
(t env)))))
91+
(assert (equalp new-tree tree))
92+
(assert (equalp '(G F E D C B A) env))))
93+
94+
;;; The actual problem to solve
95+
;;; ===========================
96+
97+
;; input representation
98+
99+
(defstruct section title reset-lesson-position lessons)
100+
101+
(defstruct (lesson (:constructor lesson (name)))
102+
name)
103+
104+
(defun sample-input ()
105+
(list (make-section :title "Getting started"
106+
:reset-lesson-position nil
107+
:lessons (list (lesson "Welcome")
108+
(lesson "Installation")))
109+
(make-section :title "Basic operator"
110+
:reset-lesson-position nil
111+
:lessons (list (lesson "Addition / Subtraction")
112+
(lesson "Multiplication / Division")))
113+
(make-section :title "Advanced topics"
114+
:reset-lesson-position t
115+
:lessons (list (lesson "Mutability")
116+
(lesson "Immutability")))))
117+
118+
;; output representation: data-structure with positions
119+
120+
(defstruct (num-section (:include section))
121+
position)
122+
123+
(defstruct (num-lesson
124+
(:include lesson)
125+
(:constructor num-lesson (name position)))
126+
position)
127+
128+
(defmethod decompose ((s section))
129+
"Children of a section: lessons"
130+
(section-lessons s))
131+
132+
(defmethod recompose ((s num-section) lessons)
133+
"Attach new lessons"
134+
(make-num-section
135+
:title (num-section-title s)
136+
:position (num-section-position s)
137+
:reset-lesson-position (num-section-reset-lesson-position s)
138+
:lessons lessons))
139+
140+
;; then environment for this problem is a plist of two counters,
141+
;; :section and :lesson. there is no dedicated type for this because
142+
;; the usage is contained in a small part of the implementation
143+
144+
(defun env (&key (section 1) (lesson 1))
145+
(list :section section :lesson lesson))
146+
147+
;; the visiting generic function is called add-positions.
148+
149+
(defgeneric add-positions (item &key env)
150+
(:documentation
151+
"Add position values to sections and lessons in tree.
152+
Secondary value is updated environment.")
153+
(:method (obj &key env)
154+
"By default, return arguments as-is"
155+
(values obj env)))
156+
157+
(defmethod add-positions ((lesson-item lesson) &key env)
158+
"lesson to num-lesson"
159+
(destructuring-bind (&key section lesson) env
160+
(values (num-lesson (lesson-name lesson-item) lesson)
161+
(env :section section :lesson (1+ lesson)))))
162+
163+
(defmethod add-positions ((section-item section) &key env)
164+
"section to num-section"
165+
(destructuring-bind (&key section lesson) env
166+
(with-accessors ((title section-title)
167+
(reset section-reset-lesson-position)
168+
(lessons section-lessons))
169+
section-item
170+
(values (make-num-section :title title
171+
:reset-lesson-position reset
172+
:lessons lessons
173+
:position section)
174+
(env :section (1+ section)
175+
:lesson (if reset 1 lesson))))))
176+
177+
;; For example:
178+
179+
(defun test ()
180+
(multiple-value-bind (out env) (walk-tree (sample-input) #'add-positions :env (env))
181+
(assert (equalp out
182+
(list (make-num-section
183+
:title "Getting started"
184+
:reset-lesson-position NIL
185+
:lessons (list (num-lesson "Welcome" 1)
186+
(num-lesson "Installation" 2))
187+
:position 1)
188+
(make-num-section
189+
:title "Basic operator"
190+
:reset-lesson-position NIL
191+
:lessons (list (num-lesson "Addition / Subtraction" 3)
192+
(num-lesson "Multiplication / Division" 4))
193+
:position 2)
194+
(make-num-section
195+
:title "Advanced topics"
196+
:reset-lesson-position T
197+
:lessons (list (num-lesson "Mutability" 1)
198+
(num-lesson "Immutability" 2))
199+
:position 3))))
200+
(assert (equalp env '(:section 4 :lesson 3)))
201+
(print out)
202+
(finish-output)))

0 commit comments

Comments
 (0)