commit of all lessons I programmed

.gitignore

@@ -0,0 +1,3 @@
+# ignore generated files
+*.lib
+*.fas

DiceOfDoom.lisp

@@ -0,0 +1,220 @@
+(defparameter *num-players* 2)
+(defparameter *max-dice* 3)
+(defparameter *board-size* 5)
+(defparameter *board-hexnum* (* *board-size* *board-size*))
+(defparameter *ai-level* 4)
+
+; DIRTY IMPERATIVE
+
+(defun gen-board()
+                                        ; Randomize board when game begins
+  (board-array (loop for n below *board-hexnum*
+                  collect (list (random *num-players*)
+                                (1+ (random *max-dice*))))))
+
+(defun draw-board (board)
+  (loop for y below *board-size*
+     do (progn (fresh-line)
+               (loop repeat (- *board-size* y)
+                  do (princ "  "))
+               (loop for x below *board-size*
+                  for hex = (aref board (+ x (* *board-size* y)))
+                  do (format t "~a-~a " (player-letter (first hex))
+                             (second hex))))))
+
+; CLEAN FUNCTIONAL
+
+(defun board-array (lst)
+                                        ; Convert board list to array
+  (make-array *board-hexnum* :initial-contents lst))
+
+(defun player-letter (n)
+  (code-char (+ 97 n)))
+
+(defun game-tree-v1 (board player spare-dice first-move)
+  (list player
+        board
+        (add-passing-move board
+                          player
+                          spare-dice
+                          first-move
+                          (attacking-moves board player spare-dice))))
+
+(let ((previous (make-hash-table :test #'equalp)))
+  (defun game-tree (&rest rest)
+    (or (gethash rest previous)
+        (setf (gethash rest previous) (apply #'game-tree-v1 rest)))))
+
+(defun add-passing-move (board player spare-dice first-move moves)
+  (if first-move
+      moves
+      (lazy-cons (list nil
+                  (game-tree (add-new-dice board player (1- spare-dice))
+                             (mod (1+ player) *num-players*)
+                             0
+                             t))
+            moves)))
+
+(defun attacking-moves (board cur-player spare-dice)
+  (labels ((player (pos)
+             (first (aref board pos)))
+           (dice (pos)
+             (second (aref board pos))))
+    (lazy-mapcan (lambda (src)
+              (if (eq (player src) cur-player)
+                (lazy-mapcan (lambda (dst)
+                          (if (and (not (eq (player dst) cur-player))
+                                   (> (dice src) (dice dst)))
+                              (make-lazy (list (list (list src dst)
+                                                     (game-tree (board-attack board
+                                                                              cur-player
+                                                                              src
+                                                                              dst
+                                                                              (dice src))
+                                                                cur-player
+                                                                (+ spare-dice (dice dst))
+                                                                nil))))
+                              (lazy-nil)))
+                             (make-lazy (neighbors src)))
+                (lazy-nil)))
+                 (make-lazy (loop for n below *board-hexnum* collect n)))))
+
+(defun neighbors-v1 (pos)
+  (let ((up (- pos *board-size*))
+        (down (+ pos *board-size*)))
+    (loop for p in (append (list up down)
+                           (unless (zerop (mod pos *board-size*))
+                             (list (1- up) (1- pos)))
+                           (unless (zerop (mod (1+ pos) *board-size*))
+                             (list (1+ pos) (1+ down))))
+       when (and (>= p 0) (< p *board-hexnum*))
+       collect p)))
+
+(let ((previous (make-hash-table)))
+  (defun neighbors (pos)
+    (or (gethash pos previous)
+        (setf (gethash pos previous) (neighbors-v1 pos)))))
+
+(defun board-attack (board player src dst dice)
+  (board-array (loop for pos from 0
+                  for hex across board
+                  collect (cond ((eq pos src) (list player 1))
+                                ((eq pos dst) (list player (1- dice)))
+                                (t hex)))))
+
+(defun add-new-dice (board player spare-dice)
+  (labels ((f (lst n)
+             (cond ((zerop n) lst)
+                   ((null lst) nil)
+                   (t (let ((cur-player (caar lst))
+                            (cur-dice (cadar lst)))
+                        (if (and (eq cur-player player)
+                                 (< cur-dice *max-dice*))
+                            (cons (list cur-player (1+ cur-dice))
+                                  (f (cdr lst) (1- n)))
+                            (cons (car lst) (f (rest lst) n))))))))
+    (board-array (f (coerce board 'list)
+                    (largest-cluster-size board player)))))
+
+(defun play-vs-human (tree)
+  (print-info tree)
+  (if (not (lazy-null (caddr tree)))
+      (play-vs-human (handle-human tree))
+      (announce-winner (cadr tree))))
+
+(defun print-info (tree)
+  (fresh-line)
+  (format t "current player = ~a" (player-letter (first tree)))
+  (draw-board (first (rest tree))))
+
+(defun handle-human (tree)
+  (fresh-line)
+  (princ "choose your move:")
+  (let ((moves (caddr tree)))
+    (labels ((print-moves (moves n)
+               (unless (lazy-null moves)
+                 (let* ((move (lazy-first moves))
+                        (action (first move)))
+                   (fresh-line)
+                   (format t "~a. " n)
+                   (if action
+                       (format t "~a -> ~a" (first action) (first (last action)))
+                       (princ "end turn.")))
+                 (print-moves (lazy-rest moves) (1+ n)))))
+      (print-moves moves 1))
+    (fresh-line)
+    (first (last (lazy-nth (1- (read)) moves)))))
+
+(defun winners (board)
+  (let* ((tally (loop for hex across board
+                   collect (first hex)))
+         (totals (mapcar (lambda (player)
+                           (cons player (count player tally)))
+                         (remove-duplicates tally)))
+         (best (apply #'max (mapcar #'cdr totals))))
+    (mapcar #'first
+            (remove-if (lambda (x)
+                         (not (eq (rest x) best)))
+                       totals))))
+
+(defun announce-winner (board)
+  (fresh-line)
+  (let ((w (winners board)))
+    (if (> (length w) 1)
+        (format t "The game is a tie between ~a" (mapcar #'player-letter w))
+        (format t "The winner is ~a" (player-letter (first w))))))
+
+                                        ; The MINIMAX Algorithm
+(defun rate-position (tree player)
+  (let ((moves (third tree)))
+    (if (not (lazy-null moves))
+        (apply (if (eq (first tree) player)
+                   #'max
+                   #'min)
+               (get-ratings tree player))
+        (score-board (second tree) player))))
+
+(defun get-ratings (tree player)
+  (take-all (lazy-mapcar (lambda (move)
+                           (rate-position (second move) player))
+                         (third tree))))
+
+;(defun handle-computer (tree)
+;  (let ((ratings (ab-get-ratings-max (limit-tree-depth tree *ai-level*)
+;                                     (first tree)
+;                                     most-positive-fixnum
+;                                     most-negative-fixnum)))
+;    (cadr (lazy-nth (position (apply #'max ratings) ratings)
+                                        ;                    (caddr tree)))))
+
+(defun handle-computer (tree)
+  (let ((ratings (get-ratings (limit-tree-depth tree *ai-level*) (first tree))))
+    (pick-chance-branch
+     (second tree)
+     (lazy-nth (position (apply #'max ratings) ratings) (third tree)))))
+
+(defun play-vs-computer (tree)
+  (print-info tree)
+  (cond ((lazy-null (third tree)) (announce-winner (second tree)))
+        ((zerop (first tree)) (play-vs-computer (handle-human tree)))
+        (t (play-vs-computer (handle-computer tree)))))
+
+(defun score-board (board player)
+  (loop for hex across board
+     for pos from 0
+     sum (if (eq (first hex) player)
+             (if (threatened pos board)
+                 1
+                 2)
+             -1)))
+
+(defun threatened (pos board)
+  (let* ((hex (aref board pos))
+         (player (first hex))
+         (dice (second hex)))
+    (loop for n in (neighbors pos)
+       do (let* ((nhex (aref board n))
+                 (nplayer (first nhex))
+                 (ndice (second nhex)))
+            (when (and (not (eq player nplayer)) (> ndice dice))
+              (return t))))))

DiceOfDoom_V2.lisp

@@ -0,0 +1,55 @@
+(load "~/Development/CLISP/LOL/DiceOfDoom.lisp")
+(load "~/Development/CLISP/LOL/lazy.lisp")
+
+(defparameter *board-size* 5)
+(defparameter *board-hexnum* (* *board-size* *board-size*))
+
+(defun limit-tree-depth (tree depth)
+  (list (first tree)
+        (first (rest tree))
+        (if (zerop depth)
+            (lazy-nil)
+            (lazy-mapcar (lambda (move)
+                           (cons (first move)
+                                 (mapcar (lambda (x)
+                                           (limit-tree-depth x (1- depth)))
+                                         (rest move))))
+                         (caddr tree)))))
+
+(defun ab-get-ratings-max (tree player upper-limit lower-limit)
+  (labels ((f (moves lower-limit)
+             (unless (lazy-null moves)
+               (let ((x (ab-rate-position (second (lazy-first moves))
+                                          player
+                                          upper-limit
+                                          lower-limit)))
+                 (if (>= x upper-limit)
+                     (list x)
+                     (cons x (f (lazy-rest moves) (max x lower-limit))))))))
+    (f (third tree) lower-limit)))
+
+(defun ab-get-ratings-min (tree player upper-limit lower-limit)
+  (labels ((f (moves upper-limit)
+             (unless (lazy-null moves)
+               (let ((x (ab-rate-position (second (lazy-first moves))
+                                          player
+                                          upper-limit
+                                          lower-limit)))
+                 (if (<= x lower-limit)
+                     (list x)
+                     (cons x (f (lazy-rest moves) (min x upper-limit))))))))
+    (f (third tree) upper-limit)))
+
+(defun ab-rate-position (tree player upper-limit lower-limit)
+  (let ((moves (third tree)))
+    (if (not (lazy-null moves))
+        (if (eq (first tree) player)
+            (apply #'max (ab-get-ratings-max tree
+                                             player
+                                             upper-limit
+                                             lower-limit))
+            (apply #'min (ab-get-ratings-min tree
+                                             player
+                                             upper-limit
+                                             lower-limit)))
+        (score-board (second tree) player))))

LoopMacroEvolution.lisp

@@ -0,0 +1,111 @@
+(defparameter *width* 93)
+(defparameter *height* 30)
+(defparameter *jungle* '(45 10 10 10))
+(defparameter *plant-energy* 80)
+(defparameter *plants* (make-hash-table :test #'equal))
+(defparameter *reproduction-energy* 200)
+
+(defun random-plant (left top width height)
+  (let ((pos (cons (+ left (random width)) (+ top (random height)))))
+    (setf (gethash pos *plants*) t)))
+
+(defun add-plants ()
+  (apply #'random-plant *jungle*)
+  (random-plant 0 0 *width* *height*))
+
+(defstruct animal x y energy dir genes)
+
+(defparameter *animals*
+  (list (make-animal :x      (ash *width* -1)
+                     :y      (ash *height* -1)
+                     :energy 1000
+                     :dir    0
+                     :genes  (loop repeat 8
+                                collecting (1+ (random 10))))))
+(defun move (animal)
+  (let ((dir (animal-dir animal))
+        (x (animal-x animal))
+        (y (animal-y animal)))
+    (setf (animal-x animal) (mod (+ x
+                                    (cond ((and (>= dir 2) (< dir 5)) 1)
+                                          ((or (= dir 1) (= dir 5)) 0)
+                                          (t - 1)))
+                                 *width*))
+    (setf (animal-y animal) (mod (+ y
+                                    (cond ((and (>= dir 0) (< dir 3)) -1)
+                                          ((and (>= dir 4) (< dir 7)) 1)
+                                          (t 0)))
+                                 *height*))
+    (decf (animal-energy animal))))
+
+(defun turn (animal)
+  (let ((x (random (apply #'+ (animal-genes animal)))))
+    (labels ((angle (genes x)
+               (let ((xnu (- x (first genes))))
+                 (if (< xnu 0)
+                     0
+                     (1+ (angle (rest genes) xnu))))))
+      (setf (animal-dir animal)
+            (mod (+ (animal-dir animal) (angle (animal-genes animal) x))
+                 8)))))
+
+(defun eat (animal)
+  (let ((pos (cons (animal-x animal) (animal-y animal))))
+    (when (gethash pos *plants*)
+      (incf (animal-energy animal) *plant-energy*)
+      (remhash pos *plants*))))
+
+(defun reproduce (animal)
+  (let ((e (animal-energy animal)))
+    (when (>= e *reproduction-energy*)
+      (setf (animal-energy animal) (ash e -1))
+      (let ((animal-nu (copy-structure animal))
+            (genes     (copy-list (animal-genes animal)))
+            (mutation  (random 8)))
+        (setf (nth mutation genes)
+              (max 1 (+ (nth mutation genes) (random 3) -1)))
+        (setf (animal-genes animal-nu) genes)
+        (push animal-nu *animals*)))))
+
+(defun update-world ()
+  (setf *animals* (remove-if (lambda (animal)
+                               (<= (animal-energy animal) 0))
+                             *animals*))
+  (mapc (lambda (animal)
+          (turn animal)
+          (move animal)
+          (eat animal)
+          (reproduce animal))
+        *animals*)
+  (add-plants))
+
+(defun draw-world ()
+  (loop for y
+     below *height*
+     do (progn (fresh-line)
+               (princ "|")
+               (loop for x
+                  below *width*
+                  do (princ (cond ((some (lambda (animal)
+                                           (and (= (animal-x animal) x)
+                                                (= (animal-y animal) y)))
+                                         *animals*)
+                                   #\M)
+                                  ((gethash (cons x y) *plants*) #\*)
+                                  (t #\space))))
+               (princ "|"))))
+
+(defun evolution ()
+  (draw-world)
+  (fresh-line)
+  (let ((str (read-line)))
+    (cond ((equal str "quit") ())
+          (t (let ((x (parse-integer str :junk-allowed t)))
+               (if x
+                   (loop for i
+                      below x
+                      do (update-world)
+                      if (zerop (mod i 1000))
+                      do (princ #\.))
+                   (update-world))
+               (evolution))))))