common lisp

(asdf:operate 'asdf:load-op 'ltk)

(use-package 'ltk)


(defun bind-red (e)
  (declare (ignore e))
  (do-msg "click on red!"))

(defun bind-green (e)
  (declare (ignore e))
  (do-msg "click on green!"))


(with-ltk ()
  (let* ((size 500)
	 (canvas (make-canvas nil :width size :height size))
	 (arc1 (create-arc canvas
			   (/ size 4) (/ size 4)
			   (* size 3/4) (* size 3/4) :start 0 :extent 180))
	 (arc2 (create-arc canvas
			   (/ size 4) (/ size 4)
			   (* size 3/4) (* size 3/4) :start 180 :extent 180)))
    (itemconfigure canvas arc1 "fill" "#ff0000")
    (itemconfigure canvas arc2 "fill" "#00ff00")
    (itemconfigure canvas arc1 "tag" "red")
    (itemconfigure canvas arc2 "tag" "green")
    (tagbind canvas "red" "<ButtonPress-1>" #'bind-red)
    (tagbind canvas "green" "<ButtonPress-1>" #'bind-green)
    (pack canvas)))

(asdf:operate 'asdf:load-op 'ltk)

(defpackage :arrow
  (:use :cl
	:ltk))

(in-package :arrow)

(defun deg->rad (deg)
  (/ (* deg (* 2 pi)) 360))

(defun rotate-point (x y angle)
  (values (- (* x (cos angle)) (* y (sin angle)))
	  (+ (* x (sin angle)) (* y (cos angle)))))

(defun main (angle &key (draw-center->end nil))
  (with-ltk ()
    (let* ((canvas (make-canvas nil :width 640 :height 480))
	   (arr-x-start   0)
	   (arr-y-start   0)
	   (arr-x-end    20)
	   (arr-y-end    20)
	   (bb-x-start  100)
	   (bb-y-start  100)
	   (bb-x-end    240)
	   (bb-y-end    340)
	   (rangle      (deg->rad (- angle)))
	   (x-center    (+ bb-x-start (/ (- bb-x-end bb-x-start) 2)))
	   (y-center    (+ bb-y-start (/ (- bb-y-end bb-y-start) 2)))
	   (a-axe       (-  bb-x-end x-center))
	   (b-axe       (-  bb-y-end y-center))
	   (arc-x-end   (* a-axe (cos rangle)))
	   (arc-y-end   (* b-axe (sin rangle))))
      (create-arc canvas
		  bb-x-start
		  bb-y-start
		  bb-x-end
		  bb-y-end
		  :style "arc"
		  :extent angle)
      (let ((h1 (create-line* canvas
			      x-center y-center
			      (+ x-center a-axe)
			      y-center))
	    (h2 (create-line* canvas
			      x-center y-center
			      x-center
			      (+ y-center b-axe))))
	(itemconfigure canvas h1 "fill" "#ff0000")
	(itemconfigure canvas h2 "fill" "#00ff00"))
      (when draw-center->end
	(let ((h3 (create-line* canvas
				x-center y-center
				(+ x-center arc-x-end)
				(+ y-center arc-y-end))))
	  (itemconfigure canvas h3 "fill" "#ff00ff")))
      (multiple-value-bind (xrot-start yrot-start)
	  (rotate-point arr-x-start arr-y-start rangle)
	(multiple-value-bind (xrot-end yrot-end)
	    (rotate-point arr-x-end arr-y-end rangle)
	  (incf xrot-start (+ x-center arc-x-end))
	  (incf yrot-start (+ y-center arc-y-end))
	  (incf xrot-end  (+ x-center arc-x-end))
	  (incf yrot-end   (+ y-center arc-y-end))
	  (create-line* canvas xrot-start yrot-start xrot-end yrot-end)))
      (multiple-value-bind (xrot-start yrot-start)
	  (rotate-point arr-x-start arr-y-start (+ (deg->rad 90) rangle))
	(multiple-value-bind (xrot-end yrot-end)
	    (rotate-point arr-x-end arr-y-end (+ (deg->rad 90) rangle))
	  (setf arr-x-start xrot-start)
	  (setf arr-y-start yrot-start)
	  (setf arr-x-end   xrot-end)
	  (setf arr-y-end   yrot-end)
	  (incf arr-x-start (+ x-center arc-x-end))
	  (incf arr-y-start (+ y-center arc-y-end))
	  (incf arr-x-end   (+ x-center arc-x-end))
	  (incf arr-y-end   (+ y-center arc-y-end)))
	(create-line* canvas arr-x-start arr-y-start arr-x-end arr-y-end))
      (pack canvas))))

;; tribonacci sequence
;; Copyright (C) 2012  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.



(defmacro matrix-elt (mat row col)
  `(nth ,col (nth ,row ,mat)))

(defun column@ (mat at)
  (mapcar #'(lambda (r) (nth at r)) mat))

(defun m-mult (a b)
  (let ((res (loop for i from 0 below (length a) collect
		  (make-list (length (first b))))))
    (loop for i from 0 below (length a) do
	 (loop for j from 0 below (length (first b)) do
	      (setf (matrix-elt res i j)
		    (reduce #'+ (mapcar #'* (nth i a) (column@ b j)) :initial-value 0))))
    res))


(defun m-pow (a exp &optional (base (copy-tree a)))
  (if (> exp 2)
      (m-pow (m-mult a base) (1- exp) base)
      (m-mult a base)))

(defun nth-fibonacci (n)
  (if (= n 0)
      0
      (matrix-elt (m-pow '((1 1) (1 0)) (- n 1)) 1 0)))


(defun nth-tribonacci (n)
  (cond
    ((= n 0)
     0)
    ((= n 1)
     1)
    (t
     (matrix-elt (m-pow '((1 1 0) (1 0 1) (1 0 0)) (1- n)) 0 2))))


(defun tribonacci-real (n &optional (res (list 1 0 0)))
  (if (= 0 n)
      (reverse res)
      (tribonacci-real (- n 1) (push (+ (first res) (second res) (third res)) res))))

(defun tribonacci (n)
  (cond
    ((= n 0)
     nil)
    ((= n 1)
     (list 0))
    ((= n 2)
     (list 0 1))
    ((= n 3)
     (list 0 0 1))
    (t
     (tribonacci-real (- n 3)))))

(defun tribonacci-ratio (n)
  (float (/ (nth-tribonacci n) (nth-tribonacci (1- n)))))

;; skew binary number random access list
;; Copyright (C) 2012  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(defclass btree ()
  ((value
    :initarg :value
    :accessor value)
   (left
    :initarg :left
    :initform nil
    :accessor left)
   (right
    :initarg :right
    :initform nil
    :accessor right)))

(defmethod print-object ((object btree) stream)
  (with-slots (value left right) object
    (format stream " <value ~a left ~a right ~a> " value left right)))

(defgeneric leaf-p (object))
(defgeneric lookup-tree (object w pos))
(defgeneric update-tree (object w pos value))

(defmethod leaf-p ((object btree))
  (and (null (left object))
       (null (right object))))


(defmethod lookup-tree ((object btree) (w integer) (pos integer))
  (cond
    ((= pos 0)
     (value object))
    (t
     (if (< pos (/ w 2))
	 (lookup-tree (left object) (truncate (/ w 2)) (- pos 1))
	 (lookup-tree (right object) (truncate (/ w 2)) (- pos 1 (truncate (/ w 2))))))))

(defmethod update-tree ((object btree) (w integer) (pos integer) value)
  (cond
    ((= pos 0)
     (make-instance 'btree :value value :left (left object) :right (right object)))
    (t
     (if (< pos (/ w 2))
	 (make-instance 'btree :value (value object)
			:left  (update-tree (left object) (truncate (/ w 2)) (- pos 1) value)
			:right (right object))

	 (make-instance 'btree :value (value object)
			:left  (left object)
			:right (update-tree (right object) (truncate (/ w 2)) (- pos 1 (truncate (/ w 2))) value))))))


(defun scons (val slist)
  (cond
    ((null slist)
     (list (list 1 (make-instance 'btree :value val))))
    ((= (length slist) 1)
     (cons (list 1 (make-instance 'btree :value val)) slist))
    ((= (first (first slist)) (first (second slist)))
     (let ((w1 (first (first slist)))
	   (w2 (first (second slist)))
	   (tree-left (second (first slist)))
	   (tree-right (second (second slist))))
       (cons (list (+ w1 w2 1)
		   (make-instance 'btree :value val :left tree-left :right tree-right))
	     (subseq slist 2))))
    (t
     (cons (list 1 (make-instance 'btree :value val)) slist))))


(defun shead (slist)
  (if (null slist)
      nil
      (value (second (first slist)))))

(defmacro with-weight-and-node ((w node slist) &body body)
  `(let ((,node (second (first ,slist)))
	 (,w (first (first ,slist))))
     ,@body))

(defun stail (slist)
  (with-weight-and-node (w node slist)
    (if (leaf-p node)
	(rest slist)
	(cons (list (truncate (/ w 2)) (left node))
	      (cons (list (truncate (/ w 2)) (right node))
		    (rest slist))))))


(defun lookup (pos slist)
  (if (null slist)
      nil
      (with-weight-and-node (w node slist)
	(if (< pos w)
	    (lookup-tree node w pos)
	    (lookup (- pos w) (rest slist))))))


(defun update (pos value slist)
  (if (null slist)
      nil
      (with-weight-and-node (w node slist)
	(if (< pos w)
	    (cons (update-tree node w pos value) (rest slist))
	    (cons (first slist)
		  (update (- pos w) value (rest slist)))))))

;; simple open addressing hashtable
;; Copyright (C) 2012  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(asdf:load-system :alexandria)

(alexandria:define-constant +hashtable-size+ 10 :test #'=)

(defun hash (string)
  (if (string/= string "")
      (let ((first-char (char-code (elt string 0))))
	(mod (+ first-char (hash (subseq string 1))) +hashtable-size+))
      0))


(defclass hashnode ()
  ((key
    :initform nil
    :accessor key
    :initarg :key
    :type 'string)
   (datum
    :initform nil
    :accessor datum
    :initarg :datum)
   (status
    :initform :empty
    :accessor status
    :initarg :status)))

(defmethod print-object ((object hashnode) stream)
  (with-slots (key datum status) object
    (print-unreadable-object (object stream :type nil :identity t)
      (format stream "key: ~s datum: ~a status: ~a" key datum status))))

(defparameter *hashtable* '())


(defun h-initialize ()
  (setf *hashtable*
	(loop for i from 0 below +hashtable-size+ collect
	     (make-instance 'hashnode))))



(defun h-add-datum (key datum &optional (address (hash key)) (count 0))
  (if (< count +hashtable-size+)
      (if (or
	   (eq (status (nth address *hashtable*)) :empty)
	   (eq (status (nth address *hashtable*)) :deleted)
	   (string= key (key (nth address *hashtable*))))
	  (progn
	    (format t "address ~a (key ~a) empty~%"
		    address key)
	    (setf (datum (nth address *hashtable*)) datum)
	    (setf (key (nth address *hashtable*)) key)
	    (setf (status (nth address *hashtable*)) :occupied))
	  (progn
	    (format t "collision for address ~a (key ~a) collide with ~a~%"
		    address key (nth address *hashtable*))
	    (h-add-datum key datum (mod (1+ address) +hashtable-size+) (1+ count))))
      (error "hashtable full for key ~s" key)))


(defun h-lookup (key &optional (address (hash key)) (count 0))
  (if (< count +hashtable-size+)
      (let ((node@address (nth address *hashtable*)))
	(if (not (eq (status node@address) :empty))
	    (if (string= (key node@address) key)
		(values (datum node@address) address)
		(h-lookup key (mod (1+ address) +hashtable-size+) (1+ count)))
	    nil))
      nil))


(defun h-delete (key)
  (multiple-value-bind (found address)
      (h-lookup key)
    (if found
	(let ((node@address (nth address *hashtable*)))
	  (setf (datum node@address) nil)
	  (setf (key node@address) nil)
	  (setf (status node@address) :deleted))
	nil)))


(defun test-hashtable ()
  (h-initialize)
  (loop
     for i in '("a" "b" "c" "d" "d" "e" "f" "g" "h" "i" "m")
     and d = 0 then (1+ d) do
       (format t "add ~a -> ~a~%" i d)
       (h-add-datum i d)
       (format t "~a~%" *hashtable*))

  (format t "delete m key ~a ~%" (hash "m"))
  (h-delete "m")
  (format t "~a~%" *hashtable*)

  (format t "re add m key ~a ~%" (hash "m"))
  (h-add-datum "m" 11)
  (format t "~a~%" *hashtable*)

  (format t "delete c key ~a ~%" (hash "c"))
  (h-delete "c")
  (format t "~a~%" *hashtable*)

  (format t "delete m key ~a ~%" (hash "m"))
  (h-delete "m")
  (format t "~a~%" *hashtable*))

(defun n-tuple (input &optional (count (length input)))
  (let ((res '()))
    (labels ((actual-n-tuple (input &optional (count (length input)) (accum '()))
	       (if (> count 0)
		   (mapcar #'(lambda (a)
			       (actual-n-tuple input (1- count) (append accum (list a))))
			   input)
		   (push accum res))))
      (actual-n-tuple input count)
      res)))



(defun 4sum (input)
  (if (or (every #'(lambda (a) (< a 0)) input)
	  (every #'(lambda (a) (> a 0)) input))
      nil
      (remove-if #'(lambda (v) (not (= (reduce #'+ v) 0)))
		 (n-tuple input 4))))

(defun min-scalar (a b)
  (reduce #'+ (mapcar #'(lambda (v1 v2) (* v1 v2))
		      (sort a #'<)
		      (sort b #'>))))

;; simplicistic build system
;; Copyright (C) 2012  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(asdf:load-system :alexandria)
(asdf:load-system :osicat)
(asdf:load-system :cl-lex)
(asdf:load-system :yacc)
(asdf:load-system :trivial-shell)

(defparameter *debug* t)

(defmacro define-stat-time (slot-name)
  (alexandria:with-gensyms (stat)
    `(defun ,(alexandria:format-symbol t "~:@(get-stat-~a~)" slot-name) (file)
       (restart-case
	   (let ((,stat (nix:stat file)))
	     (if ,stat
		 (,(alexandria:format-symbol :nix "~:@(stat-~a~)" slot-name)
		   ,stat)))
	 (use-value (value) value)))))


(define-stat-time mtime)
(define-stat-time ctime)
(define-stat-time atime)


(defun file-outdated-p (file &rest dependencies)
  (handler-bind ((nix:enoent #'(lambda (c)
				 (declare (ignore c))
				 (invoke-restart 'use-value nil))))
    (let ((atime (get-stat-atime file))
	  (mtimes (remove-if #'null (mapcar #'get-stat-mtime dependencies))))
      (when *debug*
	(format t "file ~a ~a ~a ~a~%" file atime dependencies mtimes))
      (if atime
	  (remove-if #'(lambda (mtime) (<= mtime atime)) mtimes)
	  t))))



(defclass rule ()
  ((name
    :initform nil
    :accessor name
    :initarg :name)
   (dependencies
    :initform '()
    :accessor dependencies
    :initarg :dependencies)
   (commands
    :initform '()
    :accessor commands
    :initarg :commands)))


(defparameter *all-rules* '())

(defun find-dependency (rule-name &optional (all-rules *all-rules*))
  (find-if #'(lambda (dep) (string= (name dep) rule-name)) all-rules))

(defmethod print-object ((object rule) stream)
  (format stream "name ~a dep ~a cmds ~a"
	  (name object) (dependencies object) (commands object)))

(defgeneric build (object))



(defmethod build ((object rule))
  (let ((commands-trigger (cond
			    ((not (osicat:file-exists-p (name object)))
			     t)
			    ((dependencies object)
			     nil)
			    (t
			     t))))
    (loop for i in (dependencies object) do
	 (let ((dep (find-dependency i)))
	   (if dep
	       (let ((trigger (build dep)))
		 (when trigger
		   (setf commands-trigger trigger)))
	       (when (file-outdated-p (name object) i)
		 (setf commands-trigger t)))))
    (when commands-trigger
      (if *debug*
	  (format t "rule: ~a~%~{~a~%~}~%~%" (name object) (commands object))
	  (mapc #'(lambda (cmd)
		    (format t "~a~%~{~a~}~%" cmd (subseq (multiple-value-list
							  (metashell:shell-command cmd))
							 0 2)))
		(commands object))))
    commands-trigger))


(defmethod build ((rule string))
  (build (find-dependency rule)))

(cl-lex:define-string-lexer lexer
  ("\\t(.*)" (return (values 'command $1)))
  ("([a-z,0-9,_,\\-,\\.]+):" (return (values 'name $1)))
  ("([a-z,0-9,_,\\-,\\.]+) " (return (values 'dependency $1)))
  ("([a-z,0-9,_,\\-,\\.]+)\\n" (return (values 'terminal-dependency $1))))



;; make := rule*
;; rule := name dependencies* terminal-dependency command*

(yacc:define-parser *make-parser*
  (:start-symbol make)
  (:terminals (name dependency terminal-dependency command))
  (make rules nil)

  (rules
   (rule rules)
   rule)
  (rule
   (name dep stopper commands
	 #'(lambda (name dependency terminal-dependency command)
	    (push (make-instance 'rule
				 :name name
				 :dependencies (alexandria:flatten
						(append dependency (list terminal-dependency)))
				 :commands (alexandria:flatten command))
		  *all-rules*))))

  (dep
   (dependency dep)
   dependency
   nil)

  (stopper
   terminal-dependency
   nil)
  (commands
   (command commands)
   command)

  (dependency)
  (command)
  (name)
  (terminal-dependency))



(defun read-file (file)
  (with-open-file (stream file :direction :input)
    (do ((lines ""))
	(nil)
      (handler-case
	  (setf lines (concatenate 'string lines (format nil "~%") (read-line stream)))
	(end-of-file (c)
	  (declare (ignore c))
	  (return lines))))))



(defun make (root-rule &optional (file "Makefile"))
  (yacc:parse-with-lexer (lexer (read-file file))
			 *make-parser*)
  (build root-rule))

;; cryptarithm solver with hill-climbing algorithm
;; Copyright (C) 2012  cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(eval-when (:execute)
  (setf *random-state* (make-random-state t)))

(defparameter *all-letters-values* (make-hash-table :test 'equal))
(defparameter *all-letters* (coerce "abcdefghijklmnopqrstuvwuxyz" 'list))

(defparameter *use-jump* t)
(defparameter *jump-count* 100)

(defun dump-hashtable (table)
  (maphash (lambda (k v) (format t "~s -> ~s~%" k v))  table))


(defun reverse-hashtable (table)
  (let ((res (make-hash-table :test 'equal)))
    (maphash (lambda (k v)
	       (setf (gethash v res) k))
	     table)
    res))


(defun copy-hashtable (table)
  (let ((res (make-hash-table :test 'equal)))
    (maphash (lambda (k v)
	       (setf (gethash k res) v))
	     table)
    res))


(defun random-permutation (vals)
    (if vals
	(let ((random-pos (random (length vals))))
	  (append (list (nth random-pos vals))
		  (random-permutation (append
				       (subseq vals 0 random-pos)
				       (if (< (1+ random-pos) (length vals))
					   (subseq vals (1+ random-pos))
					   nil)))))
	nil))

(defun initialize-hashtable (&optional (letters *all-letters*)
			     (hashtable *all-letters-values*)
			     (max-val 10))
  (loop for i from 0 below max-val do
       (if (nth i letters)
	 (setf (gethash i hashtable) (format nil "~a" (nth i letters)))
	 (setf (gethash i hashtable) nil)))
    hashtable)


(defun string->number (str &optional (hashtable *all-letters-values*))
  (let ((reverse-hashtable (reverse-hashtable hashtable)))
    (parse-integer
     (format nil "~{~a~}"
	     (loop for i across str collect (gethash (string i) reverse-hashtable))))))


(defun fitness (first second res hashtable &optional (operator :+))
  (ecase operator
    (:+
     (abs (- (+ (string->number first hashtable)
		(string->number second  hashtable))
	     (string->number res hashtable))))))


(defun swap (&optional
	     (hashtable *all-letters-values*)
	     (max-number 10))
  (let* ((first-random-number (random max-number))
	 (second-random-number (random max-number))
	 (first-random-val (gethash first-random-number hashtable))
	 (second-random-val (gethash second-random-number hashtable)))
    (setf (gethash first-random-number hashtable) second-random-val
	  (gethash second-random-number hashtable) first-random-val)
    hashtable))



(defun get-letter-set (the-set &rest str)
  (if str
      (apply #'get-letter-set (union the-set (remove-duplicates
					      (coerce (first str) 'list)
					      :test #'equal)
				     :test #'equal)
	     (rest str))
      the-set))


(defun first-letter-0-p (hash-table &rest words)
  (loop for i in words do
       (if (= (gethash (string (char i 0)) (reverse-hashtable hash-table)) 0)

	   (return-from first-letter-0-p t)))
  nil)


(defun solve (first second res &optional (hashtable (initialize-hashtable
						     (get-letter-set nil first second res)
						     (make-hash-table :test 'equal)))
	      (operator :+) (ct 0))
  (let ((current-fitness (fitness first second res hashtable operator)))
    (if (and (= current-fitness 0)
	     (not (first-letter-0-p hashtable first second res)))
	(progn
	  (format t "~a ~a ~a = ~a => ~a ~a ~a = ~a~%" first operator second res
		  (string->number first hashtable)
		  operator
		  (string->number second hashtable)
		  (string->number res hashtable))
	  (dump-hashtable (reverse-hashtable hashtable)))
	(let* ((swapped-hashtable (swap (copy-hashtable hashtable)))
	       (new-fitness (fitness first second res swapped-hashtable operator)))
	  (if (or
	       (and *use-jump*
		    (= (mod ct *jump-count*) 0))
	       (< new-fitness current-fitness))
	      (solve first second res swapped-hashtable operator (1+ ct))
	      (solve first second res hashtable operator (1+ ct)))))))

(defparameter *stack* nil)
(defparameter *minimum* nil)

(defparameter *compare-fun* #'<=)

(defun push-min (val)
  (when (or (null *stack*)
	    (funcall *compare-fun* val (first *minimum*)))
    (push val *minimum*))
  (push val *stack*))


(defun pop-min ()
  (let ((popped (pop *stack*)))
    (when (and popped
	       (funcall *compare-fun* popped (first *minimum*)))
      (pop *minimum*))
    popped))

(defun minimum ()
 (first *minimum*))

(defparameter *lista* '(1 2 3 2 1))

(defun my-last (l)
  (if (eql (cdr l) nil )
      (car l)
      (my-last (rest l))))

(my-last *lista*)

(defun my-but-last (l)
  (if (eql (cddr l) nil )
      l
      (my-but-last (rest l))))

(my-but-last *lista*)

(defun my-element-at (l nth)
  (if (equal nth 0)
      (progn (first l))
      (my-element-at (rest l) (1- nth))))

(my-element-at *lista* 5)

(defun my-count (l)
  (if (equal l nil)
      0
      (+ 1 (my-count (rest l) ))))

(my-count *lista*)

(defun my-reverse (l)
  (if (equal (cdr l) nil)
      (list (first l))
      (append   (my-reverse (rest l)) (list (first l)))))



(my-reverse *lista*)

(defun is-palindrome (l)
  (if (equal l (my-reverse l))
      t
      nil))


(is-palindrome *lista*)

(defparameter *tree* '(a (b (c d (e) ) f) ))



(defun my-flatten (l)
  (if (consp (first l))
      (progn (append
	      (my-flatten (car l))
	      (my-flatten (rest l))))
      (if (not (null l ))
	  (append (list (first l)) (my-flatten (rest l))))))



(my-flatten *tree*)

(defparameter *list2* '(a a a b b b a a a a c d e f f f g g h h))

(defun compress (l &optional (comp '()))
  (if (and (not (equal (first l) (car (last comp))))
	   (not (equal l nil)))
      (progn
	(setf comp (append comp (list (first l))))))
  (if (not (equal l nil))
      (compress (rest l) comp)
      comp))




(compress *list2*)
;(print *tree*)

(defun sublist (l comp count)
  (if (equal comp nil)
      (progn
	(setf comp (first l))
	(incf count)
	(sublist (rest l) comp count))
      (if (equal comp (first l))
	  (progn
	    (incf count)
	    (sublist (rest l) comp count))
	  (list comp count))))

(defun rle (l)
  (if(equal l nil)
     nil
     (progn
       (append
	(list (sublist l '() 0))
	(rle (nthcdr (second (sublist l '() 0)) l ))))))




(rle *list2*)

(defun optimize-rle(l)
  (if (not (equal l nil))
      (if (equal (second (first l)) 1)
	  (append (list (first (first l))) (optimize-rle (rest l)))
	  (append (list (first l)) (optimize-rle (rest l))))
      nil))



(optimize-rle (rle *list2*))

(defparameter *compressed-list* (optimize-rle (rle *list2*)))

(defun explode-rle (pair)
  (if (not (zerop (car (last pair))))
      (append (list (first pair)) (explode-rle (list (first pair) (1- (car (last pair))))))))


(defun uncompress-rle (cl)
  (if (consp (first cl))
      (let ( (exploded (explode-rle (first cl))))
	(append exploded (uncompress-rle (rest cl))))
      (if(not (equal cl nil))
	 (append (list (first cl)) (uncompress-rle (rest cl))))))


(uncompress-rle  *compressed-list*)

; skipped

(defun dupli (l)
  (if (equal l nil)
      nil
      (append (list (first l) (first l)) (dupli (rest l)))))

(dupli '(a b c c d))

(defun remdupli (l)
  (if (equal (cdr l) nil)
      (list (first l))
      (if (equal (first l) (second l))
	  (remdupli (append (list (second l)) (rest (rest l))))
	  (append (list (first l)) (remdupli (rest l))))))

(remdupli '(a a a a b c d d d e e f g f f h))

(defun repli (l times  &optional (count times) (savedcount count))
  (if (equal l nil)
      nil
      (if (equal l nil)
	  nil
	  (if (equal count 0)
	      (repli (rest l) times savedcount)
	      (append (list (first l)) (repli l (1- times) (1- count) savedcount))))))

(repli '(a b c) 2 )

(defun rem-mod (l pass &optional (count 1))
  (if (equal l nil)
      nil
      (if (equal (mod count pass) 0)
	    (rem-mod (rest l) pass (1+ count))
	    (append (list (first l)) (rem-mod (rest l) pass (1+ count))))))

(rem-mod '(a b c d e f g h i k) 3)
;(A B D E G H K)

(defun my-split (l thr &optional (count 0) (head nil))
  (if (< count thr)
      (progn
	(push (nth count l) head)
	(my-split l thr (1+ count) head))
      (list (reverse head) (last l (- (length l) thr)))))

(my-split '(a b c d) 2)

(defun my-slice (l left right &optional (count 0))
  (cond ((< count left)
	 (my-slice (rest l) left right (1+ count)))
	((and (>= count left) (<= count right))
	 (append (list (first l)) (my-slice (rest l) left right (1+ count))))))

(my-slice '(a b c d e f g h i k) 3 7)

;;(rotate '(a b c d e f g h) -2)
;;(G H A B C D E F)
(defun my-rotate (l entity)
  (let ((spl_l l))
    (if (< entity 0)
	(setf spl_l (my-split l (+ (length l) entity)))
	(setf spl_l (my-split l entity)))
    (append (car (cdr spl_l)) (car spl_l))))

(my-rotate '(a b c d e f g h) 3)

(defun my-remove-at (l where)
  (append (subseq l 0 where) (subseq l (1+ where))))

(my-remove-at '(a b c d) 2)

(defun my-insert-at (l what where)
  (append (subseq l 0 (1+ where)) (list what) (subseq l (1+ where))))

(my-insert-at '(a b c d e) 'alpha 2)

(defun my-range (from to &optional (count from))
  (if (<= count to)
      (if (not (equal count to))
	  (append (list from) (my-range (1+ from) to))
	  (append (list to)))
      (if (not (equal count to))
	  (append (list from) (my-range (1- from) to))
	  (append (list to)))))



(my-range  9 5)

(defun my-rnd-select (l how-many &optional picked)
  (let ( (which (random (length l))) )
    (if (> how-many 0)
	(if (not (find (nth which l) picked))
	    (progn
	      (push (nth which l) picked)
	      (append (list (nth which l)) (my-rnd-select l (1- how-many) picked)))
	    (my-rnd-select l how-many picked)))))

(my-rnd-select '(a b c d e f g h) 4)

(defun lotto-select (how-many limit &optional picked)
  (let ( (which (1+ (random limit))))
    (if (> how-many 0)
	(if (not (find which picked))
	    (progn
	      (push which picked)
	      (append (list which) (lotto-select (1- how-many) limit picked)))
	    (lotto-select how-many limit picked)))))


(lotto-select 10 10)

(defun rnd-permu (l)
  (my-rnd-select l (length l)))

(rnd-permu '(a b c d e f))
;(B A D C E F)

(defun combination(l k path  &optional (level 1) (current-node 0) (current-pos 0)  (curpath nil) (roots l) (root 0))
  (if (equal roots nil)
      path
      (if (equal k (1- level))
	  (progn
	    (if (< current-pos (length l))
		(progn
		  (if (not (find (nth current-pos l) curpath))
		      (progn
			(setf curpath (append curpath (list (nth current-pos l))))
			(setf path (append path (list curpath)))
			(setf curpath (subseq curpath 0 (1- (length curpath))))))
		  (combination l k path level current-node (1+ current-pos) curpath roots root))
		(progn
		  (setf roots (rest roots))
		  (setf curpath nil)
		  (combination l k path 1 (1+ root) 0 nil roots (1+ root)))))
	  (progn
	    (setf curpath (append curpath (list (nth current-node l))))
	    (combination l k path (1+ level) (mod (1+ current-node) (length l)) 0 curpath roots root)))))

(defparameter *list* '(a b c d))

(combination *list* 2 '())

;(combination '(a b c) 2 '()))

;;TODO

(defun bubblesort (l predicate &optional (ptr 0) (swap-made nil))
  (if (< ptr (1- (length l)))
      (if (funcall predicate (nth ptr l) (nth (1+ ptr) l))
	  (progn
	    (let ( (tmp (nth ptr l)))
	      (setf (nth ptr l) (nth (1+ ptr) l))
	      (setf (nth (1+ ptr) l) tmp)
	      (setf swap-made t)
	      (bubblesort l predicate (1+ ptr) swap-made)))
	  (progn
	    (bubblesort l predicate (1+ ptr) swap-made )))
      (if (equal swap-made t)
	  (bubblesort l predicate 0 nil)
	  l)))


(defun lengthp (l1 l2)
  (< (length l1) (length l2)))

(defparameter *listoflists* '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))

(defun lsort (l)
  (bubblesort l 'lengthp))

(defun test-list (element freq-el)
  (equal element (first freq-el)))

(defun freqc (l &optional (nwl nil))
  (if (not (equal l nil))
      (let ( (pos (position (length (first l)) nwl :from-end t :test 'test-list)))
	(if (not (equal pos nil))
	    (progn
	      (setf (second (nth pos nwl)) (1+ (second (nth pos nwl))))
	      (freqc (rest l) nwl ))
	      (progn
		(setf nwl (push (list (length (first l)) 1) nwl))
		(freqc (rest l) nwl))))
      (progn
	nwl)))

(defun construct-list-freq (l &optional (saved-l l))
  (let* ((freqs (freqc saved-l))
	 (pos (position (length (first l)) freqs :from-end nil :test 'test-list )))
    (if pos
	(append (list (list (first l) (second (nth pos freqs)))) (construct-list-freq (rest l) saved-l))
	())))

(defun freqp (e1 e2)
  (> (second e1) (second e2)))

(defun freqsort (l)
  (bubblesort l 'freqp))

(defun get-list-from-freq (l)
  (if (equal l ())
      ()
      (append (list (first (first l))) (get-list-from-freq (rest l)))))

(freqsort (construct-list-freq *listoflists*))
(get-list-from-freq (freqsort (construct-list-freq *listoflists*)))

(defun decompose-2^s*d(number &optional (power 0) factor)
  (if (equal (mod number 2) 0)
      (progn
	(setf power (1+ power))
	(decompose-2^s*d (/ number 2) power factor))
      (progn
	(setf factor number)
	(list power number))))

(decompose-2^s*d 220)

(defun alist (s)
  (loop for i from 2 below s by 1 collect i))

(defun miller-rabin (number &optional (accur 100))
  (let* ((s (first (decompose-2^s*d (1- number))))
	 (d (second (decompose-2^s*d (1- number))))
	 (a-list (alist (- number 1)))
	 (a (nth (random (length a-list)) a-list))
	 (x (mod (expt a d) number)))
    (if (equal accur 0)
	t
	(progn
	  (if (or (equal x 1) (equal x (1- number) ))
	      (miller-rabin number (1- accur))
	      (progn
		(loop named outer for r from 0 below s by 1 do
		     (let ( (x (mod (expt x (* (expt 2 r) d)) number)))
		       (if (equal x 1)
			   nil
			   (if (equal x (1- number))
			       (return-from outer (miller-rabin number (1- accur)))
			       nil))))))))))

;(miller-rabin 15)


(defun is-prime (number)
  (cond
    ((= number 1) nil)
    ((= number 2) t)
    ((= number 3) t)
    ((= (mod number 2) 0) nil)
    ( t (miller-rabin number))))

(print (is-prime 3571))

(defun my-gcd (a b)
  (if (= b 0)
      a
      (my-gcd b (mod a b))))

(gcd 36 63)

(defun coprime (a b)
  (= (my-gcd a b) 1))

(coprime 35 64)

(defun simple-phi (n &optional (count 1) )
  (if (= count n)
      0
      (if (coprime n count)
	  (progn
	    (+ 1 (simple-phi n (1+ count))))
	  (+ 0 (simple-phi n (1+ count))))))

(simple-phi 36)

(defun prime-factors-list (number &optional (count 2))
    (if (is-prime number)
	`(,number)
	(if (is-prime count)
	    (if (not (coprime number count))
		(append (list count) (prime-factors-list (/ number count) count))
		(prime-factors-list number (1+ count)))
	    (prime-factors-list number (1+ count)))))

(defun prime-factors (number)
  (bubblesort (prime-factors-list number) '>))

(prime-factors 315)

(defun compressed-factors (number)
  (rle (prime-factors number)))

(compressed-factors 36)

(defun improved-phi-list (l)
  (if (null l)
      1
      (let ((p (first (first l)))
	    (m (second (first l))))
	( * (* (1- p) (expt p (1- m))) (improved-phi-list (rest l))))))

(defun improved-phi (number)
  (let ( (l (compressed-factors number)))
    (improved-phi-list l)))

(improved-phi 36)

;TODO

(defun primes-list (from to &optional (count from))
  (if (< count to)
      (if (is-prime count)
	  (append (list count) (primes-list from to (1+ count)))
	  (primes-list from to (1+ count)))))

(primes-list 1 20)

(defun goldbach-couples (number)
  (let ( (primes (primes-list 2 number)))
    (combination primes 1 '())))

(defun goldbach (number)
  (if (evenp number)
      (let ((couples (goldbach-couples number)))
	(loop named l for i in couples do
	     (if (= (+ (first i) (second i)) number)
		 (return-from l i))))))
(goldbach 20)

(defun goldbach-list-gen (start end)
  (let ( (raw-list (loop for i from start upto end collect (goldbach i))))
    (remove-if 'null raw-list)))

(defun goldbach-list (start end)
  (mapcar #'(lambda (i) (format t "~a = ~a + ~a~%" (+ (first i) (second i)) (first i) (second i))) (goldbach-list-gen start end)))

(goldbach-list 1 100)

(defmacro and/2 (f s)
  `(and ,f ,s))

(defmacro or/2 (f s)
  `(or ,f ,s))

(defmacro not/2 (f)
  `(not f))

(defmacro nand/2 (f s)
  `(not ,(and f s)))

(defmacro nor/2 (f s)
  `(not ,(or f s)))

(defmacro xor/2 (f s)
  `(not ,(equal f s)))

(defmacro impl/2  (f s)
   `(or ,(not f) ,s))

(defmacro equl/2   (f s)
  `(equal ,f ,s))

(defun tf-matrix (number &optional (p 0) (vec (make-list number :initial-element t)))
  (let ((t-l (copy-list vec))
	(f-l (copy-list vec)))
    (if (< p number)
	(progn
	  (setf (nth p t-l) t)
	  (setf (nth p f-l) nil)
	  (append (tf-matrix number (1+ p) t-l)
		  (tf-matrix number (1+ p) f-l)))
	(list f-l))))

(tf-matrix 2)

(defun table/1 (ls tf-list &rest body)
  `(let ( ,@(loop
	       for k in ls
	       for i in tf-list
	       collect `( ,k ,i)))
     ,@body))

(table/1 '(a b) '(t nil) '(or a b))

(defun table/2 (vars  expression)
  (let ((tf-l (tf-matrix (length vars))))
    (loop for i in tf-l collect
	 (table/1 vars i expression))))

(table/2 '(a b) '(or a b))

(defun table/n (vars expression)
  (let ((t2 (table/2 vars expression))
	(tf-l (tf-matrix (length vars))))
    (loop
       for i in t2
       for j in tf-l do
	 (format t "~{~4a~} -> ~1a~%" j (eval i)))))



;A and (A or not B)
(table/n '(a b) '(and/2 a (or/2 a (not/2 b))))

(defmacro infix ((value1 operator value2))
  `(,operator ,value1 ,value2))

(infix (t and/2 t))


;; A and (A or not B)
(table/n '(a b) '(infix (a and/2 (infix ( a or/2 (not/2 b))))))

;; A and (B or C) equ A and B or A and C)

(table/n '(a b c) '(equl/2 (and/2 a (or/2 b c)) (or/2 (and/2 a b) (and/2 a c))))

(defun flatten (l)
  (if (consp (first l))
      (progn (append
	      (flatten (car l))
	      (flatten (rest l))))
      (if (not (null l ))
	  (append (list (first l)) (flatten (rest l))))))


(defclass btree ()
  ((data
    :initform nil
    :accessor data
    :initarg :data
    )
   (left
    :initform nil
    :accessor left)
   (right
    :initform nil
    :accessor right)))


(defgeneric descend (btree &key to-left )
  (:documentation "descend"))

(defgeneric traverse (btree function params )
  (:documentation "traverse"))

(defgeneric traverse-append (btree function params )
  (:documentation "traverse and return a list with results from application of 'function to each node"))

(defmethod descend ((object btree) &key (to-left t))
  (with-slots (left right) object
    (if to-left
	left
	right)))

(defmethod traverse ((object btree) function params)
  (with-slots (left right data) object
    (apply function (append (list data)  params))
    (if left
	(traverse left function  params))
    (if right
	(traverse right function params))))


(defmethod traverse-append ((object btree) function params)
  (with-slots (left right data) object
    (append
     (list
      (apply function (append (list data)  params)))
     (if (not (null left))
	 (traverse-append left function  params))
     (if (not (null right))
	 (traverse-append right function params)))))



(defmethod print-object ((object btree) (s stream))
  (print-unreadable-object (object s :type t :identity t)
    (traverse object 'print-node (list s))))



(defun print-node (data stream)
  (format stream "data: ~a ~%" data))


(setf abt (make-instance 'btree))

(setf (data abt) 'root)

(setf (left  abt) (make-instance 'btree))
(setf (right abt) (make-instance 'btree))

(setf (data (descend abt)) 'left)
(setf (data (descend abt :to-left nil)) 'right)

(traverse abt 'print-node '(t))

(print abt)

(setf teststring "a simple string to be encoded using a minimal number of bits")

(setf teststring "aaabbccccd")

;[fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)]

(setf teststring "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbccccccccccccddddddddddddddddeeeeeeeeefffff")

;(setf testlist '((#\b 15) ((#\i 1) (#\p 1))))


(defun string->list (string)
  (if (not (equal (length string) 0))
      (append (list (elt string 0 )) (string->list (subseq string 1)))
      nil))


(defun increase-freq (key freq-hashtable)
  (let ((oldfreq (gethash key freq-hashtable)))
    (if (null oldfreq)
	(setf (gethash key freq-hashtable) 1)
	(setf (gethash key freq-hashtable) (1+ oldfreq)))))

(defun freq-count (char-list &optional (res (make-hash-table :test 'equalp )))
  (if (not (null char-list))
      (let* ((first-char (first char-list))
	     (rest-list  (rest char-list))
	     (element-res-pos  (gethash first-char res)))
	(increase-freq first-char res)
      (freq-count rest-list res))
      res))


(defun construct-trees-list (hashtable)
  (loop for k being the hash-keys in hashtable  collect
       (make-instance 'btree :data k)))


(defun add-freq (data hashtable)
  (gethash data hashtable))


(defun calc-freq-tree (bt hashtable )
  (let ((freq-children (remove-if #'null (traverse-append bt 'add-freq (list hashtable)))))
    (reduce #'+ freq-children)))


(defun get-minimum-pos (btree hashtable)
  (let ((max (loop
		for i in btree
		maximize (calc-freq-tree i hashtable) into j
		finally (return j)))
	(minpos 0))
    (loop
       for i in btree
       for pos = 0 then (1+ pos) do
	 (if (< (calc-freq-tree i hashtable)  max)
	     (progn (setf max (calc-freq-tree i hashtable))
		    (setf minpos pos))))
       minpos))





(defun remove-return-element(btree minpos)
  (values (append (subseq btree 0 minpos) (subseq btree (1+ minpos))) (nth minpos btree)))


(defun reduce-huffman-tree (forest hashtable)
  (if (> (length forest) 1)
      (let* ((first-min (get-minimum-pos forest hashtable)))
	(multiple-value-bind (subforest mintree) (remove-return-element forest first-min)
	  (let* ((second-min (get-minimum-pos subforest hashtable)))
	    (multiple-value-bind (second-subforest second-mintree) (remove-return-element subforest second-min)
	      (let ((nwtree (make-instance 'btree)))
		(setf (left  nwtree) mintree)
		(setf (right nwtree) second-mintree)
		(setf forest (append second-subforest (list nwtree)))
		(reduce-huffman-tree forest hashtable))))))
      forest))



(defun huffman-tree(string)
      (let* ((hashtable (freq-count (string->list teststring)))
	     (forest (construct-trees-list hashtable)))
	(reduce-huffman-tree forest hashtable)))


(print (first (huffman-tree teststring)))

(defun calculate-code (&key (one t))
  (if one
      (list 0)
      (list 1)))



(defparameter codes '())

(defun huffman-codes (tree &optional (code '()))
  (if (or (null (left tree)) (null (right tree)))
      (progn
	(let ((finalcode (append code (list (data tree)))))
	  (push finalcode codes)))
      (progn
	(when (left tree)
	  (setf code (append code (calculate-code :one t)))
	  (huffman-codes (left tree) code))
	(setf code (subseq code 0 (1- (length code))))
	(when (right tree)
	  (setf code (append code (calculate-code :one nil)))
	  (huffman-codes (right tree) code)))))


(huffman-codes (first (huffman-tree teststring)))


(print codes)
(setf codes '())

(defvar tree1 '(a (b (d nil nil) (e nil nil)) (c nil (f (g nil nil) nil))))
(defvar tree2 '(a nil nil))
(defvar tree3 '(3 nil))
(defvar tree4 '(3 (4 nil nil) nil))
(defvar tree5 '())
(defvar tree6 '(3 nil nil))

; tree  := nil  | node child child
; child := tree | nil

(defun is-leaf (tree)
  (if (and (null (second tree))
	   (null (third tree)))
      t
      nil))

(defun istree (atree)
    (if (or (null atree)
	    (equal (length atree) 3))
	(progn
	  (if (is-leaf atree)
	      t
	      (if (and (append (list (istree (second atree))))
		       (append (list (istree (third atree)))))
		  t
		  nil)))
	nil))


(istree tree1)
(istree tree2)
(istree tree3)
(istree tree4)
(istree tree5)

(define-condition malformed-tree-error (error)
  ((text :initarg :text :accessor text)))

(defun count-nodes-list (tree)
  (if (not (istree tree))
      (error 'malformed-tree-error :text "Not a tree")
      (list
       (if (null tree)
	   0
	   1)
       (if (not (null (second tree)))
	   (count-nodes (second tree))
	   0)
       (if (not (null (third tree)))
	   (count-nodes (third tree))
	   0))))

(defun count-nodes (tree)
  (reduce #'+ (count-nodes-list tree)))

(count-nodes tree4)
(count-nodes  (second tree4))
(count-nodes  (third tree4))
(count-nodes  tree5)


(defun check-balance (tree)
  (if (not (istree tree))
      (error 'malformed-tree-error :text "Not a tree")
      (if (null tree)
	  tree
	  (if (< (count-nodes (second tree))
		 (count-nodes (third tree)))
	      (cdr tree)
	      (cddr tree)))))

(check-balance tree1)

(defun balancedp (tree)
  (if (not (istree tree))
      (error 'malformed-tree-error :text "Not a tree")
      (if (null tree)
	  t
	  (if (or (= 1
		     (abs (- (count-nodes (second tree))
			     (count-nodes (third tree)))))
		  (= 0
		     (abs (- (count-nodes (second tree))
			     (count-nodes (third tree))))))

	      (and
	       (balancedp (second tree))
	       (balancedp (third tree)))
	      nil))))

(balancedp '(a (b (c nil nil) nil) (d nil nil)))


(defun add-subtree (leaf subtree)
  (if (istree subtree)
      (setf (car leaf) subtree)
      (error 'malformed-tree-error :text "Not a tree")))


(defun add-subtree-data (subtree data &key (leaf nil) (left nil) (right nil))
  (let ((nwl (list data nil nil)))
    (cond
      ((null subtree)
       (setf subtree nwl))
      (leaf
       (add-subtree subtree nwl))
      (left
       (add-subtree (cdr subtree) nwl))
      (right
       (add-subtree (cddr subtree) nwl))
      (t (add-subtree subtree nwl))))
  (copy-tree subtree))


(defun compose (fun arg)
  (if (null fun)
      arg
      `(,(first fun) ,(compose (rest fun) arg))))

(compose '(first second) '(r nil nil))

(defmacro path(where what)
  `(compose ,where ,what))

(macroexpand-1 '(path (car cdr car cdr) tree1))

(defun add-node (tree where what)
  `(setf ,(path where tree) ,what))

(defun get-node (tree where)
  (eval (path where `(quote ,tree))))

(defun add-data(tree where what)
  (eval (add-node tree where `(list (quote ,what) nil nil))))

(defun add-data-copy(tree where what)
  (let ((nwtree (copy-tree tree)))
    (add-data `(quote ,nwtree) where what)
    (copy-tree nwtree)))

(defun add-balanced (tree data)
  (let ((less-populated (check-balance tree)))
    (if (null (first less-populated))
	(add-subtree-data less-populated data :leaf t)
	(add-balanced (first less-populated) data))))


(defun add-balanced-copy (tree data)
  (let ((nwtree (copy-tree tree)))
    (if (null nwtree)
	(setf nwtree (list data nil nil))
	(add-balanced nwtree data))
    (copy-tree nwtree)))


(defun cbal-tree (node-numbers &optional (data 'x) (tree '()))
  (if (> node-numbers 0)
      (cbal-tree (1- node-numbers) data (add-balanced-copy tree data))
      tree))


(defun all-btree(numnodes data)
  (let ((forest '()))
    (labels ((permute (tree data nums where)
	       (if (= nums 0)
		   (progn
		     (pushnew (copy-tree tree ) forest :test #'tree-equal))

		   (let ((pathl (append '(second) where ))
			 (pathr (append '(third)  where )))

		     (if (null (get-node tree pathl))
			 (progn
			   (permute (add-data-copy tree pathl data)  data (1- nums) '()))
			 (permute tree data nums pathl))

		     (if (null (get-node tree pathr))
			 (progn

			   (permute (add-data-copy tree pathr data)  data (1- nums) '()))
			 (permute tree data nums pathr))))))


      (permute '(root nil nil) data numnodes '()))
    forest))


(defun all-balanced-trees (number &optional (data 'x))
  (let ((all-tree (all-btree (1- number) data)))
    (remove-if-not #'balancedp all-tree)))

(all-balanced-trees 4)

(defun tree-mirror (tree1 tree2)
  (let* ((1-l (if (null (second tree1)) nil t))
	 (1-r (if (null (third  tree1)) nil t))
	 (2-l (if (null (second tree2)) nil t))
	 (2-r (if (null (third  tree2)) nil t))
	 (children (list 1-l 1-r 2-l 2-r)))
    (if (and (equal 1-r 2-l) (equal 1-l 2-r))
	(if (every #'null children)
	    (progn
	      t)
	    (progn
	      (let ((l-branch (tree-mirror (second tree1) (third  tree2)))
		    (r-branch (tree-mirror (third  tree1) (second tree2))))
		(if (equal l-branch r-branch)
		    t
		    nil))))
	nil)))

(defun test-symmetric (tree)
  (tree-mirror (second tree) (third tree)))

(defun bst-cons(nodes)
  (let ((btree (list (first nodes) nil nil)))
    (labels ((bst-add (tree new-nodes &optional (root tree))
	       (if (not (null new-nodes))
		   (let ((node (first new-nodes)))
		     (if (<= node (first tree))
			 (progn
			   (if (null (second tree))
			       (progn
				 (add-subtree-data tree node :left t)
				 (bst-add root (rest new-nodes)))
			       (bst-add (second tree) new-nodes root)))
			 (progn
			   (if (null (third tree))
			       (progn
				 (add-subtree-data tree node :right t)
				 (bst-add root (rest new-nodes)))
			       (bst-add (third tree) new-nodes root))))))))
      (bst-add btree (rest nodes)))
    (copy-tree btree)))


(bst-cons '(3 2 5 7 1))

(test-symmetric (bst-cons '(5 3 18 1 4 12 21)))
(test-symmetric (bst-cons '(3 2 5 7 4)))

(defun sym-cbal-tree(node-numbers)
  (let ((forest (all-balanced-trees node-numbers)))
    (remove-if-not #'test-symmetric forest)))

(sym-cbal-tree 5)

(defun btree-height(tree)
  (if (not (istree tree))
      (error 'malformed-tree-error :text "Not a tree")
      (let ((max-height 0))
	(labels ((height (tree &optional (curr-h 1))
		   (if (not (null tree))
		       (progn
			 (height (second tree) (1+ curr-h))
			 (if (> curr-h max-height)
			     (setf max-height curr-h))
			 (height (third tree) (1+ curr-h))
			 (decf curr-h)
			 (if (> curr-h max-height)
			     (setf max-height curr-h))
			 curr-h))))

	  (height tree)
	  max-height))))



(defun hbal-treep(tree)
  (if (not (null tree))
      (let* ((h-l (btree-height (second tree)))
	     (h-r (btree-height (third tree)))
	     (diff-h (abs (- h-l h-r))))

	(if (<= diff-h 1)
	    (and t
		 (hbal-treep (second tree))
		 (hbal-treep (third tree)))
	    nil))
      t))


(hbal-treep '(ROOT (X (X NIL NIL) NIL) NIL))


(defun all-hbtree (h data &optional (accum '()))
  (case h
    ((0)
     (push nil accum))

    ((1)
     (push (list data nil nil) accum))

    (otherwise
     (let ((subtrees-1 (all-hbtree (- h 1) data))
	   (subtrees-2 (all-hbtree (- h 2) data)))
       (labels ((comb (one two)
		  (if (null two)
		      nil
		      (progn
			(push (list data one (first two)) accum)
			(comb one (rest two)))))
		(collect (one two)
		  (if (null one)
		      nil
		      (progn
			(comb (first one) two)
			(collect (rest one) two)))))

	 (collect subtrees-1 subtrees-1)
	 (collect subtrees-2 subtrees-1)
	 (collect subtrees-1 subtrees-2))
       accum))))


(all-hbtree 2 'x)

;; n(0) = 0
;; n(1) = 1
;; n(h) where h > 1 = n(h-1) + n(h-2) + 1

(defun hbtree-min-nodes(height)
  (cond
    ((= height 0)
     0)
    ((= height 1)
     1)
    (t
     (+ 1 (hbtree-min-nodes (1- height)) (hbtree-min-nodes (- height 2))))))

(hbtree-min-nodes 3)

(defun hbtree-max-height (number)
  (loop named the-loop
     for height = 0 then (1+ height)
     for n = (hbtree-min-nodes height) then (hbtree-min-nodes height)
     do
       (cond
	 ((= n number)
	  (return-from the-loop height))
	 ((> n number)
	  (return-from the-loop (1- height))))))


(hbtree-max-height 15)

(defun all-hntree-with-nodes (nodes)
  (let ((res '()))
    (loop for i from 0 to (hbtree-max-height nodes)
	 do
	 (progn
	   (setf res (append res (all-hbtree i 'x) res))))
    (remove-if-not #'(lambda(x) (if (= nodes (count-nodes x)) t nil)) res)))

(all-hntree-with-nodes 4)

(defun traverse-btree (tree &optional (funct (function print)) (parfunc '()))
  (when (not (null tree))
    (apply funct tree parfunc)
    (traverse-btree (second tree) funct)
    (traverse-btree (third tree) funct)))


;(traverse-btree tree1)

(defun count-leaves (tree)
  (let ((res 0))
    (traverse-btree tree #'(lambda (x) (if (is-leaf x) (incf res))))
    res))

(count-leaves tree1)

(defun collect-leaves (tree)
  (let ((res '()))
    (traverse-btree tree #'(lambda (x) (if (is-leaf x) (push (first x) res))))
    res))


(collect-leaves tree1)

(defun collect-nodes (tree)
  (let ((res '()))
    (traverse-btree tree #'(lambda (x) (if (not (is-leaf x)) (push (first x) res))))
    res))

(collect-nodes tree1)

(defun collect-level (tree level)
  (let ((res '()))
    (labels ((collect (tree level &optional (actlvl 1))
	       (when (not (null tree))
		 (when (= actlvl level)
		   (push (first tree) res))
		 (collect (second tree) level (1+ actlvl))
		 (collect (third tree)  level (1+ actlvl)))))
      (collect tree level))
    res))

(defun complete-binary-tree (nodes)
  (let ((res '(1 nil nil)))
    (labels ((grow (tree &optional (address 1))
	       (let* ((addr-l (* 2 address))
		      (addr-r (1+ addr-l)))

		 (if (<= addr-l nodes)
		     (progn
		       (setf (second tree) (list addr-l nil nil))
		       (grow (second tree) addr-l)))

		 (if (<= addr-r nodes)
		     (progn
		       (setf (third tree) (list addr-r nil nil))
		       (grow (third tree)  addr-r))))))
      (grow res))
    res))

(complete-binary-tree 2)

(defparameter *tree64* '(n (k (c (a nil nil) (h (g (e nil nil) nil) nil)) (m nil nil)) (u (p nil (s (q nil nil) nil)))))


(defun layout-btree (tree)
  (let ((x 0)
	(y 0))
    (labels ((layout (atree)
	       (when (not (null atree))
		 (incf y)
		 (layout (second atree))
		 (incf x)
		 (format t "~a ~a ~a ~%" (first atree) x (- 100 y))
		 (layout (third atree))
		 (decf y))))
      (layout tree))))

(format t "layout 1~%")
(layout-btree *tree64*)

(defparameter *tree65* '(n (k (c (a nil nil) (e (d nil nil) (g nil nil))) (m nil nil)) (u (p nil (q nil nil)) nil)))

(defun layout-btree-2 (tree)
  (let ((max-h (btree-height tree))
	(x 0)
	(y 0))
    (labels ((layout (atree &key (left t))
	       (when (not (null atree))

		 (if left
		     (progn

		       (if (= y max-h)
			   (setf x (+ x -1))
			   (setf x (+ x(- (* (- max-h y) 2))))))
		     (progn

		       (if (= y max-h)
			   (setf x (+ x 1))
			   (setf x (+ x (* (- max-h y) 2))))))
		 (incf y)
		 (format t "~a ~a ~a ~%" (first atree) x (- 100 y))
		 (layout (third atree) :left nil)


		 (layout (second atree) :left t)

		 (decf y)


		 (if left
		     (progn
		       (if (= y max-h)
			   (setf x (- x -1))
			   (setf x (- x (- (* (- max-h y) 2))))))
		     (progn
		       (if (= y max-h)
			   (setf x (- x 1))
			   (setf x (- x (* (- max-h y) 2)))))))))
      (layout tree))))

(format t "layout 2~%")
(layout-btree-2 *tree65*)

(defparameter *tree66* '(n (k (c (a nil nil 0 0) (e (d nil nil 0 0) (g nil nil 0 0) 0 0) 0 0) (m nil nil 0 0) 0 0) (u (p nil (q nil nil 0 0) 0 0) nil 0 0) 0 0))

(defconstant +minw+ 10 "minimum width")

(defun calc-w-branch (tree)
  (let ((start 1000)
	(end -1000))
    (labels ((calc (atree)
	       (when (not (null atree))
		 (calc (second atree))

		 (when (< (fourth atree) start)
		   (setf start (fourth atree)))

		 (calc (third atree))

		 (when (> (fourth atree) end)
		   (setf end (fourth atree))))))
      (calc tree))
    (values start end)))




(defun transl-branch (tree dx dy)
  (traverse-btree tree #'(lambda (x) (progn
				       (setf (fourth x) (+ dx  (fourth x)))
				       (setf (fifth x) (+ dy (fifth x)))))))


(defun prepare-btree (tree)
  (let ((x 0)
	(y 0))
    (labels ((layout (atree)
	       (when (not (null atree))

		 (incf y)
		 (transl-branch (second atree) (- +minw+) y)
		 (transl-branch (third atree)  +minw+ y)
		 (decf y)
		 (layout (second atree))

		 (layout (third atree))
		 )))
      (layout tree))))

(defun print-btree-pos (tree)
  (traverse-btree tree #'(lambda (x) (format t "~a ~a ~a~%" (first x) (fourth x) (- 100 (fifth x))))))


(defun check-clash2 (node branch)
  (let ((res nil))
    (traverse-btree branch #'(lambda (x) (when (and (= (fourth node) (fourth x))
						    (= (fifth node)  (fifth x)))
					   (setf res t))))
    res))

(defun check-clash (branch1 branch2)
  (let ((res nil))
    (traverse-btree branch1 #'(lambda (x) (setf res (check-clash2 x branch2))))
    res))


(defun adjust (node)
  (when (check-clash (second node) (third node))
    (transl-branch (second node) (- +minw+) 0)
    (transl-branch (third node) +minw+ 0)
    (adjust node)))

(defun layout-btree-3 (tree)
  (prepare-btree tree)
  (labels ((layout (atree)
	     (when (not (null atree))
	       (layout (second atree))
	       (layout (third atree))

	       (when (not (is-leaf atree))
		 (adjust atree)))))
    (layout tree)))

(format t "layout 3~%")
(layout-btree-3 *tree66*)
(print-btree-pos *tree66*)

; missing

(defun preorder-visit (tree)
  (let ((res '()))
    (traverse-btree tree #'(lambda (x) (push (first x) res)))
    (reverse res)))

(preorder-visit tree1)


(defun traverse-btree-inorder (tree &optional (funct (function print)) (parfunc '()))
  (when (not (null tree))
    (traverse-btree-inorder (second tree) funct)
    (apply funct tree parfunc)
    (traverse-btree-inorder (third tree) funct)))


(defun inorder-visit (tree)
  (let ((res '()))
    (traverse-btree-inorder tree #'(lambda (x) (push (first x) res)))
    (reverse res)))

(defun build-btree (preorder-list inorder-list)
  (labels ((build (preord inord)
	     (when (not (null preord))
	       (let ((posin (position (first preord) inord :test #'equal)))
		 (cond
		   ((null posin)
		    (build (subseq preord 1) inord))
		   ((= (length inord) 1)
		    (list (first preord) nil nil))
		   ((= posin 0)
		    (list (first preord) nil (build (subseq preord 1) (subseq inord 1))))
		   ((= posin (- (length inord) 1))
		    (list (first preord)
			  (build (subseq preord 1)
				 (subseq inord 0 (length inord)))
			  nil))
		   ((not (null posin))
		    (list (first preord)
			  (build (subseq preord 1) (subseq inord 0 posin))
			  (build (subseq preord 1) (subseq inord (1+ posin))))))))))
    (build preorder-list inorder-list)))


(build-btree (preorder-visit tree1)
	     (inorder-visit tree1))

;; TREE := NIL | NODE TREE TREE
;; NODE := [a-z]+
;; NIL  := '.'

(defconstant +validlabel+ "abcdefghijklmnopqrstuvwxyz")
(defconstant +NIL+ #\.)

(defun parse-btree-imperative (str)
  (let ((res '(nil))
	(ptrstr 0)
	(has-error nil))
    (labels ((ptree (tree)
	       (when (< ptrstr (length str))
		 (if (null (first res))
		     (progn ;; start
		       (rplaca res (elt str ptrstr))
		       (rplacd res (list nil))
		       (rplacd (cdr res) (list nil))
		       (incf ptrstr)
		       (ptree (cdr tree))
		       (ptree (cddr tree)))
		     (when (pnode tree)
		       (ptree (cdar tree))
		       (ptree (cddar tree))))))
	     (pnode (tree)
	       (if (char= (elt str ptrstr) +NIL+) ;; stop
		   (progn
		     (incf ptrstr)
		     nil)
		   (if (find (elt str ptrstr) +validlabel+ :test #'char=)
		       (progn
			 (if (null (first res))
			     (progn
			       (rplaca res (elt str ptrstr))
			       (rplacd res (list nil))
			       (rplacd (cdr res) (list nil))
			       (incf ptrstr)
			       t)
			     (progn
			       (rplaca tree (list (elt str ptrstr) nil nil))
			       (incf ptrstr)
			       t)))
		       (progn
			 (setf has-error t)
			 nil)))))
      (ptree res))

    (values (copy-tree res) ptrstr has-error)))


(parse-btree-imperative "abd..e..c.fg...")


(defun parse-btree-functional (str)
  (let ((ptrstr 0)
	(has-error nil))
    (labels ((ptree ()
	       (if (char= (elt str ptrstr) +NIL+) ;; stop
		   (progn
		     (incf ptrstr)
		     nil)
		   (if (find (elt str ptrstr) +validlabel+ :test #'char=)
		       (progn
			 (incf ptrstr)
			 (list (elt str (- ptrstr 1)) (ptree) (ptree)))
		       (progn
			 (setf has-error t)
			 nil)))))

      (restart-case
	  (values (ptree) ptrstr has-error)
	(set-syntax-error () (values '() 0 t))))))

(defun parse-btree (str)
  (handler-bind ((simple-type-error
		  #'(lambda (c)
		      (invoke-restart 'set-syntax-error))))
    (parse-btree-functional str)))

(parse-btree "abd..e..c.fg...")

(tree-equal (parse-btree-imperative "abd..e..c.fg...")
	    (parse-btree-functional "abd..e..c.fg..."))

(defconstant +board-size+ 8)

(defun free-position-p (x y my-x my-y)
  (cond
    ((or (= y my-y)
	 (= (abs (- my-y y))
	    (abs (- my-x x)))
	 (= my-x x))
     nil)
    (t t)))

(defun free-pos (positions my-x my-y &optional (count 0))
  (if (null positions)
      t
      (if (free-position-p count (first positions)
			   my-x my-y)
	  (free-pos (rest positions) my-x my-y (1+ count))
	  nil)))

(defun 8-queens (pos &optional (nw-x (length pos)) (nw-y 0))
  (if (< nw-y +board-size+)
      (if (< nw-x +board-size+)
	  (if (free-pos pos nw-x nw-y)
	      (8-queens (append pos (list nw-y)) (1+ nw-x) 0)
	      (8-queens pos nw-x (1+ nw-y)))
	  pos)
      (let ((last-x (- (length pos) 1))
	    (last-y (incf (car (last pos)))))
	(8-queens (subseq pos 0 (- (length pos) 1)) last-x last-y))))

(8-queens '())

(defconstant +board-size+ 8)

(defconstant +max-moves+ (* +board-size+ +board-size+))

(defun generate-board (&optional (size  +board-size+))
  (loop for i from 0 below size collect
       (make-list size :initial-element nil)))

(defun knight-out-of-board (x y)
  (if (or (< x 0)
	  (>= x +board-size+)
	  (>= y +board-size+)
	  (< y 0))
      t
      nil))

(defmacro board-element (board x y)
  `(nth ,x (nth ,y ,board)))

(defun set-board-element (board x y value)
  (setf (board-element board x y) value))

(defun knight-possible-moves(x y)
  (list (list (+ x 1) (+ y 2))
	(list (- x 1) (+ y 2))

	(list (+ x 1) (- y 2))
	(list (- x 1) (- y 2))

	(list (+ x 2) (- y 1))
	(list (+ x 2) (+ y 1))

	(list (- x 2) (- y 1))
	(list (- x 2) (+ y 1))))

(defun knight-filter-valid-moves (board x y)
  (let ((all-moves (knight-possible-moves x y)))

    (remove-if #'(lambda (move)
		   (if (or (knight-out-of-board (first move)  (second move))
			   (not (null (board-element board (first move)  (second move)))))
		       t
		       nil))
	       all-moves)))

(defun sort-moves-multiplicity (moves-list)
  (sort moves-list #'< :key #'(lambda (x) (length (second x)))))

;; use Warnsdorff's algorithm

(defun knight-tour-calc (board x y &optional (count 0))
  (if (= count 0)
     (progn
       (set-board-element board x y count)
       (knight-tour-calc board x y (1+ count)))
     (when (< count +max-moves+)
       (let ((moves (knight-filter-valid-moves board x y)))
	 (let ((moves-2 (loop for i in moves collect
			     (list i (knight-filter-valid-moves board (first i) (second i))))))
	   (setf moves-2 (first (first (sort-moves-multiplicity moves-2))))
	   (set-board-element board (first moves-2) (second moves-2) count)
	   (knight-tour-calc board (first moves-2) (second moves-2) (1+ count)))))))


(defun knight-print-hline ()
  (loop for i from 0 to (* +board-size+ 4) do
       (if (= (mod i 4) 0)
	   (format t "+")
	   (format t "-")))
  (format t "~%"))


(defun knight-tour (startx starty)
  (let ((board (generate-board)))
    (knight-tour-calc board startx starty)
    (knight-print-hline)

    (loop for i in board do
	 (progn
	   (format t "|~{~3a|~}~%" i)
	   (knight-print-hline)))))


(knight-tour 1 1)

(defun permutation (li)
  (let ((res-partial '())
	(res '()))
    (labels ((perm (start tail)
	       (let ((partial-tree '()))
		 (loop for i in start do
		      (loop for j in (set-difference tail i) do
			   (push (append  i (list j)) partial-tree)))
		 (setf res-partial (reverse (copy-tree partial-tree))))))
      (loop for ct in li do
	   (do ((start (list (list ct)) res-partial))
	       ((null (set-difference li (first start)))
		(progn
		  (setf res (append res res-partial))
		  (setf res-partial '())))
	     (perm start li))))
    res))


(defclass tree ()
  ((data
    :initform 0
    :accessor data
    :initarg :data)
   (children
    :initform nil
    :accessor children)
   (parent
    :initform nil
    :accessor parent
    :initarg :parent)
   (visited
    :initform nil
    :accessor visited
    :initarg :visited)

   (last-added-pointer
    :initform nil
    :accessor last-added-pointer
    :initarg :last-added-pointer)
   (last-visited-pointer
    :initform nil
    :accessor last-visited-pointer
    :initarg :last-visited-pointer)))



(defgeneric descendcdr (tree where)
  (:documentation "descend"))

(defgeneric descend (tree where &key track set-visited)
  (:documentation "descend"))

(defgeneric up-to-parent(tree &key track)
  (:documentation "set visited and return parent"))

(defgeneric add-children (tree the-data &key track)
  (:documentation "add-children"))

(defgeneric tree-traverse (tree &optional funct params)
  (:documentation "traverse"))

(defgeneric copy (tree dest)
  (:documentation "copy tree"))

(defgeneric root (tree)
  (:documentation "get root node"))


(defmethod initialize-instance :after ((object tree) &key)
  (setf (last-visited-pointer object) (root object)))

(defmethod descendcdr ((object tree) where)
  (with-slots (children) object
	(nthcdr where children)))

(defmethod descend ((object tree) where &key (track t) (set-visited nil))
  (with-slots (children) object
    (if track
	(setf (last-visited-pointer (root object)) (nth where children)))

    (if set-visited
	(setf (visited (last-visited-pointer (root object))) t))

     (nth where children)))

(defmethod up-to-parent((object tree) &key (track t))
  (with-slots (children) object
    (if track
	(setf (last-visited-pointer (root object)) (parent object)))
    (parent object)))


(defmethod add-children ((object tree) the-data  &key (track t))
  (with-slots (children parent) object
    (if track
	(setf (last-added-pointer (root object)) (car (last children))))

    (setf children
	  (append children
		  (list (make-instance 'tree :data the-data  :parent object))))))


(defmethod tree-traverse ((object tree) &optional (funct (function print)) (parfunc '()))
  (with-slots (children parent data) object
    (apply funct object parfunc)
    (loop for i in children do
	 (tree-traverse i funct parfunc))))

(defun find-data-children (tree val)
  (let ((par (parent tree)))
    (if (null par)
	nil
	(let ((childr (children par)))
	  (position val childr :key #'data)))))

(defun where-am-i(atree node-value)
  (let ((res '()))
    (labels ((df (my-tree)
	       (push (find-data-children my-tree (data my-tree)) res)
	       (if (/= (data my-tree) node-value)
		   (progn

		     (loop for i from 0 below (length (children my-tree)) do
			  (progn
			    (df (descend my-tree i :track nil))))
		     (setf res (subseq res 1)))
		   (return-from where-am-i (reverse res)))))



      (df atree))
    res))


(defun go-to-node (tree where)
  (cond ((null where)
	 nil)
	((and (= (length where) 1)
	      (equal (first where) nil))
	 (root tree))
	(t
	 (let ((res (root tree))
	       (path (subseq where 1)))
	   (loop for i in path do
		(setf res (descend res i :track nil :set-visited nil)))
	   res))))


(defmethod copy ((obj tree) (dest tree))
  (labels ((rec-copy (src goal)
	     (setf (data goal) (data src))
	     (setf (visited goal) (visited src))
	     (loop
		for i in (children src)
		for j from 0 upto (length (children src))
		do
		  (progn
		    (add-children goal 'd :track nil)
		    (rec-copy i (descend goal j :track nil))))))
    (when (not (eq obj dest))
      (rec-copy obj dest)))
  (if (null (last-added-pointer obj))
      (setf (last-added-pointer dest) nil)
      (setf (last-added-pointer dest) (go-to-node dest (where-am-i obj (data (last-added-pointer obj))))))
      (if (null (last-visited-pointer obj))
	  (setf (last-visited-pointer dest) nil)
	  (setf (last-visited-pointer dest) (go-to-node dest (where-am-i obj (data (last-visited-pointer obj))))))
  dest)


(defmethod root ((object tree))
  (with-slots (parent) object
    (if (null parent)
	object
	(root parent))))

(defmacro if-null (test then else)
  `(if (null ,test)
       ,then
       ,else))


(defmethod print-object ((object tree) stream)
  (with-slots (children parent data) object
    (print-unreadable-object (object stream )
      (if-null parent
	       (format stream "data : ~a parent ==> nil ~%" data)
	       (format stream "data : ~a parent ==> ~a ~%" data (data parent)))
      (if-null (last-added-pointer object)
	       (format stream "added pointer : nil ~%")
	       (format stream "added pointer : ~a ~%" (data (last-added-pointer object))))
      (if-null (last-visited-pointer object)
	       (format stream "visited pointer : nil ~%")
	       (format stream "visited pointer : ~a ~%" (data (last-visited-pointer object))))

      (format stream "IS VISITED: ~a~%" (visited object))
      (format stream "START children fom ~a~%" data)
      (loop for i in children do
	   (print-object i stream))
      (format stream "END children from ~a~%" data))))


(defparameter *tree92* (make-instance 'tree :data 1))
(add-children *tree92* 0) ; 0
(add-children *tree92* 0) ; 1
(add-children *tree92* 0) ; 2
(add-children *tree92* 0) ; 3
(add-children *tree92* 0) ; 4

(add-children (descend *tree92* 4 :track nil :set-visited nil) 0) ; c -> 0
(add-children (descend *tree92* 4 :track nil :set-visited nil) 0) ; c -> 1

(add-children (descend (descend *tree92* 4 :track nil :set-visited nil) 1 :track nil :set-visited nil) 0) ; c -> d -> 0

(add-children (descend *tree92* 4 :track nil :set-visited nil) '0) ; c -> 2

(add-children (descend (descend *tree92* 4 :track nil :set-visited nil) 2 :track nil :set-visited nil) 0) ; c -> e -> 0

(add-children (descend (descend (descend *tree92* 4 :track nil :set-visited nil) 2 :track nil :set-visited nil) 0 :track nil :set-visited nil) 0) ; c -> e -> q -> 0

(add-children (descend (descend (descend *tree92* 4 :track nil :set-visited nil) 2 :track nil :set-visited nil) 0 :track nil :set-visited nil) 0) ; c -> e -> q -> 1

(add-children (descend (descend (descend (descend *tree92* 4 :track nil :set-visited nil) 2 :track nil :set-visited nil) 0 :track nil :set-visited nil) 1 :track nil :set-visited nil) 0) ; c -> e -> q -> n -> 0

(defparameter *treetest* (make-instance 'tree :data 1))

(add-children *treetest* 0)
(add-children *treetest* 0)
(add-children *treetest* 0)

(add-children (descend *treetest* 2 :track nil :set-visited nil) 0)
(add-children (descend *treetest* 2 :track nil :set-visited nil) 0)
(add-children (descend (descend *treetest* 2 :track nil :set-visited nil)
		       1 :track nil :set-visited nil) 0)

(defparameter *dummy* (make-instance 'tree :data 1))
(add-children *dummy* 0)
(add-children (descend *dummy* 0) 0)
(add-children *dummy* 0)


(defparameter *dummy2* (make-instance 'tree :data 1))
(add-children *dummy2* 0)
(add-children *dummy2* 0)


(defun tree-count(tree)
  (let ((count 1)
	(res '()))
    (tree-traverse tree (lambda (x) (progn
				      x
				      (push count res)
				      (incf count))))
    (reverse res)))

(defun tree-nodelist(tree)
  (let ((res '()))
    (tree-traverse tree (lambda (x) (push (data x) res)))
    res))


(defun tree-check-diff (a b values)
  (let ((diff (- (max a b) (min a b))))
    (if (find diff values)
	nil
	diff)))


(defun difference-list (tree)
  (let ((res '()))
    (tree-traverse tree #'(lambda (node)
			    (when (and (not (null (parent node)))
				       (plusp (data node)))

			      (if (tree-check-diff (data node) (data (parent node)) res)
				  (push (tree-check-diff (data node) (data (parent node)) res) res)
				  (return-from difference-list '())))))
    res))




(defun label-all (tree values)
  (tree-traverse tree #'(lambda (x) (progn
				      (setf (data x) (first values))
				      (setf values (rest values))))))


(defun tree-label-bruteforce(tree &key (get-all nil))
  (let ((permutations (permutation (tree-count tree)))
	(results '()))
    (dolist (label permutations results)
      (let ((cp (copy tree (make-instance 'tree))))
	(label-all cp label)
	(when (difference-list cp)
	  (push cp results)
	  (if (not get-all)
	      (return-from tree-label-bruteforce results)))))))

(defun reset-all-pointers (forest)
  (mapc #'(lambda (x) (progn
			(setf (last-visited-pointer x) nil)
			(setf (last-added-pointer x) nil)))
	forest))

(defun init-pool (skeleton values &optional (accum '()))
  (if (null values)
      (reverse accum)
      (let ((a-tree (make-instance 'tree)))
	(copy skeleton a-tree)
	(setf (data a-tree) (first values))
	(print a-tree)
	(init-pool skeleton (rest values) (push a-tree accum)))))


(defun step-remap (atree values)
  (let ((found-children '()))
    (labels ((one-step (mytree value)
	       (let ((not-visited (position nil (children (last-visited-pointer mytree)) :key #'visited)))
		 (if not-visited
		     (progn
		       (let ((cp (copy mytree (make-instance 'tree))))
			 (descend (last-visited-pointer cp) not-visited :track t :set-visited t)
			 (setf (data (last-visited-pointer cp)) value)
			 (push cp found-children)
			 cp))
		     (progn
		       (if (not (null (parent (last-visited-pointer mytree))))
			   (progn
			     (setf (last-visited-pointer mytree) (parent (last-visited-pointer mytree)))
			     (one-step mytree value))
			   nil))))))
      (mapcar #'(lambda (x) (one-step atree x)) values))
    (reverse found-children)))



(defun construct (atree vals)
  (let ((res '()))
    (labels ((constr (atree vals)
	       (if (not (null atree))
		   (let ((nw (step-remap atree vals)))
		     (if (not (null nw))
			 (progn
			   (constr (first nw) (set-difference vals (tree-nodelist (first nw))))
			   (loop for i in (rest nw) do
				(constr i (set-difference vals (tree-nodelist i)))))
			 (when (difference-list atree)
			   (push  atree res)
			   (return-from construct atree)))))))


      (constr atree vals))
    res))



(defun explore (skeleton values)
  (let ((starting-pool (init-pool skeleton values)))
    (loop for i in starting-pool do
	 (progn
	   (format t ".")
	   (force-output)
	   (let ((res (construct i (remove (data (root i)) values))))
	     (if res
		 (return-from explore res)))))))


(defun tree-label (atree)
  (explore atree (tree-count atree)))

(format t "TEST:~% ~a ~%~%" (tree-label *treetest*))
(format t "TEST 92:~% ~a ~%~%" (tree-label *tree92*))

(defun split-number (number &optional (accum '()))
  (if (< number 10)
      (push number accum)
      (let ((div (/ number 10))
	    (rem (mod number 10)))
	(split-number (floor div) (push rem accum)))))

(format t "~{~r~^-~}~%" (split-number 175))

(defconstant +boardsize+ 9)

(defun make-board (size)
  (let ((l (make-list size :initial-element '())))
    (loop for i on l do
	 (setf (car i) (make-list size :initial-element 0)))
    l))


(defun print-hline (size)
  (loop
     for i from 0 below (+ (* size 2) 3) do
       (if (= 0 i )
	   (format t "+")
	   (if (= (mod i (+ (/ size 3) 4)) 0)
	       (format t "+")
	       (format t "-"))))
  (format t "+~%"))

(defun print-board (board)
  (print-hline (length (first board)))
  (loop
     for rows in board
     for k = 1 then (1+ k)
     do
       (progn
	 (loop
	    for cols in rows
	    for i = 1 then (1+ i)
	    do
	    (progn
	      (when (= 1 i)
		(format t "|"))
	      (format t "~2a" cols)
	      (if (= 0 (mod i 3 ))
		  (format t "|"))
	      (if (= 0 (mod i 9 ))
		  (format t "~%")))))
       (when (= 0 (mod k 3 ))
	 (print-hline (length (first board))))))


(defun count-not-empty (board)
    (reduce #'+ (mapcar #'(lambda (z) (reduce #'+ z)) (mapcar #'(lambda (x) (mapcar #'(lambda (y) (if (not (zerop y)) 1 0)) x)) board))))

(defun valid-colp (board value x)
  (let ((res t))
    (loop for rows in board do
	 (when (= (nth x rows) value)
	   (setf res nil)))
    res))

(defun valid-rowp (board value y)
  (let ((res t))
    (loop for cols in (nth y board) do
	 (when (= cols value)
	   (setf res nil)))
    res))


(defun valid-boxp (board value x y)
  (let ((first-col (* (floor (/ x (/ +boardsize+ 3))) 3))
	(first-row (* (floor (/ y (/ +boardsize+ 3))) 3))
	(res t))
    (loop for rows from first-row below (+ first-row 3) do
	 (loop for cols from first-col below (+ first-col 3) do
	      (when (= value (nth cols (nth rows board)))
		(setf res nil))))
    res))





(defun valid-positionp (board value x y)
  (and (valid-colp board value x)
       (valid-rowp board value y)
       (valid-boxp board value x y)))


(defun read-game (stream)
  (let ((board (make-board +boardsize+)))
    (loop for i from 0 below (expt +boardsize+ 2) do
	 (let ((r (parse-integer (string (read-char stream)) :junk-allowed t))
	       (col (floor (/ i +boardsize+)))
	       (row (mod i +boardsize+)))
	   (when (and (not (null r))
		      (< r 10)
		      (> r 0))
	     (setf (nth row (nth col board)) r))))
    board))



(defmacro get-value (board x y)
  `(nth ,x (nth ,y ,board)))

(defun find-vacancy (board &optional (x 0) (y 0))
  (if (= (count-not-empty board) 81)
      (values nil nil)
      (if (and (> x (- +boardsize+ 1))
	       (> y (- +boardsize+ 1)))
	  (values nil nil)
	  (progn
	    (if (= 0 (get-value board x y))
		(values x y)
		(if (= (mod (1+ x) +boardsize+) 0)
		    (find-vacancy board 0 (mod (1+ y) +boardsize+))
		    (find-vacancy board (mod (1+ x) +boardsize+)  y)))))))




(defun explore (board &key (show-progress nil))
  (labels ((expl (the-board the-x the-y)
	     (if show-progress
		 (format t "filled places so far ~a ~%" (count-not-empty the-board)))
	     (force-output)
	     (multiple-value-bind (vx vy)
		 (find-vacancy the-board the-x the-y)
	       (if (null vx)
		   (progn
		     (print-board the-board)
		     (return-from explore the-board))
		   (progn
		     (loop for i from 1 to +boardsize+ do
			  (progn
			    (if (valid-positionp the-board i vx vy)
				(let ((cp (copy-tree the-board)))
				  (setf (get-value cp vx vy) i)
				  (expl cp vx vy))))))))))
    (expl board 0 0)))

(defparameter *game* (read-game *standard-input*))

(print-board *game*)

(explore *game*)

(defclass nonogram ()
    ((row-hints
      :initform '()
      :accessor row-hints
      :initarg :row-hints)
     (col-hints
      :initform '()
      :accessor col-hints
      :initarg :col-hints)
     (board
      :initform '()
      :accessor board
      :initarg :board)
     (empty-cell
      :initform #\_
      :reader empty-cell)
     (occupied-cell
      :initform #\X
      :reader occupied-cell)))


(defmethod initialize-instance :after ((object nonogram)
				       &key (w 8) (h 9) col-h row-h)
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (setf (board object) (copy-tree (make-list h :initial-element
				    (copy-list (make-list w :initial-element empty-cell)))))
    (setf col-hints col-h)
    (setf row-hints row-h)))

(defmethod print-object ((object nonogram) stream)
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (loop
       for i in board
       for j = 0 then (1+ j) do
	 (progn
	   (format stream "|~{~1d|~}" i)
	   (format stream "~{~2d~}~%" (nth j row-hints))))

    (let* ((cols-h (copy-tree col-hints))
	   (maxl (length (first (sort cols-h #'> :key (lambda (x) (length x)))))))

      (loop for i from 0 below maxl do
	   (loop for j in col-hints do
		(when (<= (length j) maxl)
		  (if (null (nth i j))
		      (format stream "~2a" #\Space)
		      (format stream "~2d" (nth i j)))))
	   (format stream "~%")))))



(defmacro row (nono y)
  `(nth ,y (board ,nono)))

(defmacro cell (nono x y)
  `(nth ,x (row ,nono ,y)))

(defun put-block (nono xstart y len)
  (if (< (+ xstart (- len 1)) (length (row nono y)))
      (loop for i from 0 below len collect
	   (setf (cell nono (+ xstart i) y) (occupied-cell nono)))
      nil))


(defmacro occupied-cellp (nono x y)
  `(char= (cell ,nono ,x ,y) (occupied-cell ,nono)))

(defmacro row-col-counts (nonogram len1 len2 x y)
  `(let ((sum (gensym))
	(res (gensym))
	(start (gensym)))
     (setf sum t)
     (setf res '())
     (setf start t)
     (with-slots (row-hints col-hints board empty-cell occupied-cell) ,nonogram
       (loop for i from 0 below ,len1 do
	    (progn
	      (setf sum t)
	      (setf start t)
	      (setf res (append res (list (list 0))))
	      (loop for j from 0 below ,len2 do
		   (if (occupied-cellp ,nonogram ,x ,y)
		       (if (not (null sum))
			   (progn
			     (incf (car (last (car (last res)))))
			     (setf start nil))
			   (progn
			     (setf (car (last res)) (append (car (last res)) (list 1)))
			     (setf sum t)))
		       (when (not start)
			 (setf sum nil)))))))
     res))




(defgeneric col-counts (nonogram))

(defgeneric row-counts (nonogram))

(defgeneric shift-row (nonogram x y &optional count))

(defgeneric game-completed (nonogram))

(defgeneric compatible-boardp (nonogram))

(defgeneric copy-board (nonogram))

(defmethod col-counts ((object nonogram))
  (row-col-counts object (length (row object 0)) (length (board object)) i j))

(defmethod row-counts ((object nonogram))
  (row-col-counts object (length (board object)) (length (row object 0)) j i))

(defmethod  shift-row ((object nonogram) x y &optional (count (- (length (row object 0)) 1)))
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (if (< count x)
	(row object y)
	(if (occupied-cellp object count y)
	    (if (= count (- (length (row object 0)) 1))
		nil
		(progn
		  (setf (cell object (1+ count) y) occupied-cell)
		  (setf (cell object count y) empty-cell)
		  (shift-row object x y (- count 1))))
	    (shift-row object x y (- count 1))))))

(defmethod game-completed ((object nonogram))
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (let ((rowc (row-counts object))
	  (colc (col-counts object))
	  (res nil))
      (if (and (equal rowc row-hints)
	       (equal colc col-hints))
	  (setf res t))
      res)))


(defun compatible-listp (current hint)
  (if (> (length current) (length hint))
      nil
      (progn
	(loop for i from 0 below (- (length current) 1) do
	     (when (> (nth i current)
		      (nth i hint))
	       (return-from compatible-listp nil)))
	(<= (nth (- (length current) 1) current)
	    (nth (- (length current) 1) hint)))))

(defmethod compatible-boardp ((object nonogram))
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (let ((colc (col-counts object))
	  (rowc (row-counts object))
	  (res t))
      (loop for i from 0 below (length rowc) do
	   (when (not (compatible-listp (nth i rowc)
					(nth i row-hints)))
	     (setf res nil)))

      (loop for j from 0 below (length colc) do
	   (when (not (compatible-listp (nth j colc)
					(nth j col-hints)))
	     (setf res nil)))
      res)))


(defmethod copy-board ((object nonogram))
  (with-slots (row-hints col-hints board empty-cell occupied-cell) object
    (let ((cp (make-instance 'nonogram
				  :w (length (first board))
				  :h (length board)
				  :row-h row-hints
				  :col-h col-hints)))
      (setf (board cp) (copy-tree board))
      cp)))


(defun init-row-with-hints (nonogram y)
  (let ((hints (nth y (row-hints nonogram))))
    (loop
       for len in hints
       and pos = 0 then (+ pos len 1) do
	 (put-block nonogram pos y len))))

(defun row-length (nonogram &optional (y 0))
  (length (row nonogram y)))

(defun col-length (nonogram)
  (length (board nonogram)))

(defun other-block-out-of-boardp (nonogram x y lenblock rem-hints)
  (let ((min-space (+ (reduce #'+ rem-hints) (length rem-hints))))
    (if (<= (+ min-space lenblock x)
	   (row-length nonogram y))
	nil
	t)))

(defun explore (the-game &key (show-progress nil))
  (labels ((expl (nonogram &optional (x 0) (y 0) (hints (nth y (row-hints the-game))))
	     (declare (optimize (speed 3) (safety 0)))
	     (declare (fixnum x y))
	     (if show-progress
		 (format t "~a~%" nonogram))
	     (if (game-completed nonogram)
		 (return-from explore nonogram)
		 (if (not (null hints))
		     (loop for i from x upto (- (length (row nonogram y)) (first hints)) do
			  (let ((cp-nono (copy-board nonogram)))
			    ;(format t "outer ~a first rest hints ~a hints ~a~% nono~%~a~%" (other-block-out-of-boardp cp-nono i y (first hints) (rest hints)) (first hints) (rest hints) cp-nono)
			    (if (and (not (other-block-out-of-boardp cp-nono i y (first hints) (rest hints)))
				     (put-block cp-nono i y (first hints))) ; always true?
				(if (compatible-boardp cp-nono)
				    (expl cp-nono (+ i (first hints) 1) y (rest hints))))))
		     (when (< (1+ y) (col-length nonogram)) ;hints empty, go to next row
		       (expl (copy-board nonogram) 0 (1+ y)))))))
    (expl the-game)))





; |X|X|X|3
; |_|X|_|1
; |_|X|X|2
;  1 3 1
;      1



(defparameter minigame (make-instance 'nonogram
				      :w 3 :h 3
				      :row-h '((3) (1) (2))
				      :col-h '((1) (3) (1 1))))

(format t "completed!!!! ~%~a~%" (explore minigame :show-progress nil))

(defparameter game (make-instance 'nonogram
				  :w 8 :h 9
				  :row-h '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2))
				  :col-h '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3))))


(format t "completed!!!! ~%~a~%" (explore game))


(defparameter lambda-game (make-instance 'nonogram
				       :w 10 :h 12
				       :row-h '((2) (1 2) (1 1) (2) (1) (3) (3) (2 2) (2 1) (2 2 1) (2 3) (2 2))
				       :col-h '((2 1) (1 3) (2 4) (3 4) (4) (3) (3) (3) (2) (2))))

(format t "completed!!!! ~%~a~%" (explore lambda-game :show-progress nil))


;; (defparameter wiki-game (make-instance 'nonogram
;;                                     :w 20 :h 20
;;                                     :row-h '((3) (5) (3 1) (2 1) (3 3 4) (2 2 7) (6 1 1) (4 2 2) (1 1) (3 1) (6) (2 7) (6 3 1) (1 2 2 1 1) (4 1 1 3) (4 2 2) (3 3 1) (3 3) (3) (2 1))
;;                                     :col-h '((2) (1 2) (2 3) (2 3) (3 1 1) (2 1 1) (1 1 1 2 2) (1 1 3 1 3) (2 6 4) (3 3 9 1) (5 3 2) (3 1 2 2) (2 1 7) (3 3 2) (2 4) (2 1 2) (2 2 1) (2 2) (1) (1))))

;; (format t "completed!!!! ~%~a~%" (explore wiki-game :show-progress nil))