--- a/lists.lisp	Fri Oct 04 11:49:00 2019 +0200
+++ b/lists.lisp	Mon Oct 07 11:04:39 2019 +0200
@@ -36,3 +36,36 @@
   (if (not bindings)
       `(funcall (lambda () ,@body))
       `(my-let (,(car bindings)) (my-let* ,(cdr bindings) ,@body))))
+
+(defmacro my-if (condition expr-t expr-f)
+  `(or
+   (and ,condition (or ,expr-t t))
+   ,expr-f))
+
+(defmacro my-looptimes (n &body body)
+  `(let ((i 0))
+     (tagbody
+	start
+	,@body
+	(incf i)
+	(unless (eql i ,n) (go start)))))
+
+(defmacro my-looplist ((name list) &body body)
+  `(let ((_list ,list))
+     (tagbody
+      start
+	(let ((,name (pop _list)))
+	  ,@body
+	  (when _list (go start)))
+	)))
+
+(defun access-nth (list n)
+  (if (= n 1) (car list) (access-nth (cdr list) (1- n))))
+
+(defmacro make-nth-accessor (name n)
+  (let ((list-arg-name (gensym)))
+    `(defun ,name (,list-arg-name) (access-nth ,list-arg-name ,n))))
+
+(make-nth-accessor my-first 1)
+(make-nth-accessor my-second 2)
+(make-nth-accessor my-third 3)

--- a/test3.lisp	Fri Oct 04 11:49:00 2019 +0200
+++ b/test3.lisp	Mon Oct 07 11:04:39 2019 +0200
@@ -1,9 +1,91 @@
 ;; syntax test
 
 (load "~/dev/lisp/lists.lisp")
+(load "~/dev/lisp/macroplay.lisp")
 
-(print (my-foldl
-	(lambda (a x) (+ a (* x 2)))
-	0
-	(my-range 0 10000001)))
+;; heap?
+
+(defun make-heap (&optional (max-size 64))
+  (list 0 (make-array max-size :initial-element nil)))
+
+(defun heap-get-pos (h pos) (aref (cadr h) pos))
+(defun heap-set-pos (h pos el) (setf (aref (cadr h) pos) el))
+
+(defun swap-heap-elems (heap ix1 ix2)
+  (let ((tmp (heap-get-pos heap ix1)))
+    (heap-set-pos heap ix1 (heap-get-pos heap ix2))
+    (heap-set-pos heap ix2 tmp)))
+(defun left-child (ix) (+ 1 (* 2 ix)))
+(defun right-child (ix) (+ 2 (* 2 ix)))
+(defun parent (ix) (floor (/ ix 2)))
+
+(defun bubble-heap-up (heap pos)
+  "Take the element at pos and move elements as long as the invariant is not fulfilled."
+  (loop while (and (> pos 0) (< (heap-get-pos heap (parent pos)) (heap-get-pos heap pos)))
+     do
+       (swap-heap-elems heap (parent pos) pos)
+       (setf pos (parent pos))))
 
+(defun bubble-heap-fill (heap)
+  "After popping the top element, move elements until the invariant is fulfilled"
+  (let ((pos 0)
+	(len (length heap)))
+	(loop while (heap-get-pos heap pos) do
+	     (let ((left-elem (heap-get-pos heap (left-child pos)))
+		   (right-elem (heap-get-pos heap (right-child pos))))
+	       (cond ((and (eql nil left-elem) (not (eql nil right-elem)))
+		      (progn
+			(swap-heap-elems heap (right-child pos) pos)
+			(setf pos (right-child pos))))
+		     ((and (eql nil right-elem) (not (eql nil left-elem)))
+		      (progn
+			(swap-heap-elems heap (left-child pos) pos)
+			(setf pos (left-child pos))))
+		     ((and (eql nil left-elem) (eql nil right-elem)) (return))
+		     ('t
+		      (if (> left-elem right-elem)
+			  (progn
+			    (swap-heap-elems heap (left-child pos) pos)
+			    (setf pos (left-child pos)))
+			  (progn
+			    (swap-heap-elems heap (right-child pos) pos)
+			    (setf pos (right-child pos))))))))
+	(heap-set-pos heap pos nil)))
+
+(defvar *debug-heap-level* 0)
+(defun debug-heap-at-level (heap target-level pos)
+  (defun or_ (a b) (or a b))
+  (if (/= target-level *debug-heap-level*)
+      (let ((*debug-heap-level* (1+ *debug-heap-level*)))
+	(or_ (debug-heap-at-level heap target-level (left-child pos))
+	     (debug-heap-at-level heap target-level (right-child pos))))
+      (if (< pos (length heap))
+	  (progn (format t "~a " (heap-get-pos heap pos)) 't)
+	  nil)))
+
+(defun debug-heap (heap)
+  (loop
+     for level from 0
+     with ok = 't
+     while ok
+     do
+       (format t "level ~a:~%" level)
+       (setf ok (debug-heap-at-level heap level 0))
+       (format t "~%")))
+
+(defun put-heap (heap elem)
+  (let ((elems (if (listp elem) elem (list elem)))
+	(h (cadr heap)))
+    (loop for e in elems do
+	 (let ((newpos (car heap)))
+	   (heap-set-pos heap newpos e)
+	   (incf (car heap))
+	   (bubble-heap-up heap newpos)))))
+
+(defun pop-heap (heap)
+  (let ((elem (heap-get-pos heap 0)))
+    (if (eql 0 (car heap))
+	nil
+	(progn (decf (car heap))
+	       (bubble-heap-fill heap)
+	       elem))))