Common-Lisp alife simulation "soup"

soup.lisp

(require 'cl-ppcre)
(require 'vecto)
(require 'hunchentoot)

(defpackage :soup
  (:use :cl-ppcre :common-lisp :vecto :hunchentoot :flexi-streams)
  (:export :start-soup))

(in-package :soup)

;; world is a 2d, square, array.
;; world-language.
(defun make-world (size)
  (make-array (list size size) :initial-element nil))

(defun world-size (world)
  (array-dimension world 0))

(defun world-ref (world x y)
  (let* ((size (world-size world))
         (x    (mod x size))
         (y    (mod y size)))
    (aref world x y)))
           
(defun (setf world-ref) (value world x y)
  (let* ((size (world-size world))
         (x    (mod x size))
         (y    (mod y size)))
    (setf (aref world x y) value)))


(defconstant +A 0)
(defconstant +G 1)
(defconstant +C 2)
(defconstant +T 3)

(defun char->gene (char)
  (case char
    (#\A 0)
    (#\G 1)
    (#\C 2)
    (#\T 3)))

(defun gene->char (gene)
  (case gene
    (0 #\A)
    (1 #\G)
    (2 #\C)
    (3 #\T)))

(defun pair->string (n)
  (let ((str (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
    (vector-push-extend  (gene->char (ash n -2))   str)
    (vector-push-extend  (gene->char (logand n 3)) str)
    str))

(defconstant +AA 00)  ;; push A
(defconstant +AG 01)  ;; ...  G
(defconstant +AC 02)  ;; ...  C
(defconstant +AT 03)  ;; ...  T
(defconstant +GA 04)  ;; dup
(defconstant +GG 05)  ;; drop
(defconstant +GC 06)  ;; swap
(defconstant +GT 07)  ;; gt
(defconstant +CA 08)  ;; skip/occupied
(defconstant +CG 09)  ;; skip/=
(defconstant +CC 10)  ;; nop
(defconstant +CT 11)  ;; multiply
(defconstant +TA 12)  ;; eat
(defconstant +TG 13)  ;; hump
(defconstant +TC 14)  ;; move
(defconstant +TT 15)  ;; die


(defun random-gene ()
  (random 4))

(defun random-pair ()
  (random 16))

;; stack
(defconstant +STACK-SIZE+ 10)

(defclass stack ()
  ((s  :initform '()
       :accessor stack)))

(defmethod stack-push (value (stack stack))
    (if (> (length (stack stack)) (1- +STACK-SIZE+))
        (progn
         (setf (car (stack stack)) value)
         (stack stack))
        (push value (stack stack))))

(defmethod stack-pop ((stack stack))
  (if (> (length (stack stack)) 0)
      (pop (stack stack))
      (random-gene)))

(defmethod stack-size ((stack stack))
  (length (stack stack)))
      

;; creature.
(defclass creature ()
  ((genome :initarg  :genome
           :accessor creature-genome)
   (pc     :initarg  :pc
           :initform 0
           :accessor creature-pc)
   (ni     :initform nil
           :accessor creature-ni)   
   (stack  :initform (make-instance 'stack)
           :initarg  :stack
           :accessor creature-stack)))

;; genome.
(defun make-genome (size)
  (make-array size :element-type '(mod 16)))


(defun list->genome (list)
  (let ((genome (make-genome (length list))))
    (loop for i from 0 to (1- (length list))
       do
         (setf (aref genome i) (nth i list)))
    genome))

(defun genome-length (genome)
  (length genome))


(defun genome-instr (genome pc)
  (aref genome pc))


(defun genome-length (genome)
  (array-dimension genome 0))

(defun string->genome (string)
  (when (not (zerop (mod (length string) 2)))
    (error "genome must be in pairs."))
  (list->genome (loop for i from 0 to (1- (/ (length string) 2))
                   as j = (* i 2)
                   collect (let ((c1 (aref string j))
                                 (c2 (aref string (1+ j))))
                             (logior (ash (char->gene c1) 2)
                                     (char->gene c2))))))


(defun genome-reproduce (genome1 genome2)
  (let ((ng (make-genome (min (genome-length genome1)
                             (genome-length genome2)))))
    (loop 
       for g1 from 0 to (1- (genome-length genome1))
       for g2 from 0 to (1- (genome-length genome2))
       do (setf (aref ng g1) 
                (let ((r (random 1000)))
                  (cond 
                    ((< r 400) (genome-instr genome1 g1))
                    ((< r 800) (genome-instr genome2 g2))
                    ((< r 950) (random-pair))
                    (t (logxor (genome-instr genome1 g1) 
                               (genome-instr genome2 g2)))))))
    ng))
  

(defmethod creature-reproduce ((c1 creature) (c2 creature))
  (make-instance 'creature 
                 :genome (genome-reproduce 
                          (creature-genome c1)
                          (creature-genome c2))))
                 

;; only really used for debugging.
(defun genome->list (genome)
  (loop for g from 0 to (1- (genome-length genome))
     collect (pair->string (genome-instr genome g))))

(defun just-died? ()
  (= (random 1000) 42))

(defun battle-weight (delta)
  (* 40 (/ delta +STACK-SIZE+)))

(defun battle (creature1 creature2)
  (let*  ((l1  (stack-size (creature-stack creature1)))
          (l2  (stack-size (creature-stack creature2)))
          (d   (- l1 l2))
          (w   (battle-weight d))
          (r   (random 100)))
    (> r (+ 50 w))))

(defun multiply-successfulp ()
  (> (random 100) 80))

;; locations
(defstruct location x y)

(defun offspring-location (location)
    (make-location :x (1+ (location-x location))
                   :y (1+ (location-y location))))


(defun world-null! (world location)
  (setf (world-ref world (location-x location) (location-y location)) nil))


(defmethod creature-set-pc ((creature creature) pc)
      (setf (creature-pc creature) 
            (mod pc (genome-length (creature-genome creature)))))

(defmethod creature-inc-pc ((creature creature))
  (creature-set-pc creature
                   (1+ (creature-pc creature))))

(defmethod creature-skip-pc ((creature creature))
  (creature-set-pc creature
                   (+ 2 (creature-pc creature))))

(defmethod creature-current-instruction ((creature creature))
  (genome-instr (creature-genome creature)
                (creature-pc     creature)))

(defun creature-die (world location)
  (world-null! world location))

(defun creature-stack-push (creature value)
  (stack-push value (creature-stack creature)))


(defun cpc++ (c) (creature-inc-pc c))
(defun cpcskp (c) (creature-skip-pc c))
(defun cpush (c v) (creature-stack-push c v))
(defun cpop  (c) (stack-pop (creature-stack c)))


(defun gene->location (gene location)
  (let ((x (location-x location))
        (y (location-y location)))
    (make-location :x (+ x (case gene
                             (0 0)
                             (1 1)
                             (2 0)
                             (3 -1)))
                   :y (+ y (case gene
                             (0 -1)
                             (1 0)
                             (2 1)
                             (3 0))))))
              

(defun location-occupiedp (world location)
  (null (world-ref world (location-x location) (location-y location))))

(defun location-occupiedp* (world creature location)
  (location-occupiedp 
   world
   (gene->location (cpop creature) location)))
  

(defun run-creature! (world x y)
  (let* ((location (make-location :x x :y y))
         (c (world-ref world (location-x location) (location-y location))))
    (if (not (null c))
        (let ((gene (if (null (creature-ni c))
                        (creature-current-instruction c)
                        (progn ;; gross handing for GT (pop & exec)
                          (let ((ni (creature-ni c)))
                            (setf (creature-ni c) nil)
                            (cpc++ c)
                            ni)))))
          (if (just-died?)
              (world-null! world location)
              (case gene
                ;; push instructions
                (0 (cpush c +A) (cpc++ c))
                (1 (cpush c +G) (cpc++ c))
                (2 (cpush c +C) (cpc++ c))
                (3 (cpush c +T) (cpc++ c))
                
                ;; stack instructions
                ;; DUP
                (4 (let ((v (cpop c))) (cpush c v) (cpush c v)) (cpc++ c))
                ;; DROP
                (5 (cpop c) (cpc++ c))
                ;; SWAP
                (6 (let ((x (cpop c))
                         (y (cpop c)))
                     (cpush c y)
                     (cpush c x)
                     (cpc++ c)))
                ;; POP TWICE AND EXECUTE.. WAIT, WHAT?!
                (7 (let ((x (cpop c))
                         (y (cpop c)))
                     (setf (creature-ni c)
                           (logior (ash x 2) y))
                     (cpc++ c)))
                (8 (if (location-occupiedp* world c location)
                       (cpc++ c)
                       (cpcskp c)))
                (9 (if (= (cpop c) (cpop c))
                       (cpcskp c)
                       (cpc++ c)))
                ;; NOP
                (10 (cpc++ c))
                ;; MULTIPLY IN A DIRECTION
                (11 (let* ((nl  (gene->location (cpop c) location))
                           (x   (location-x nl))
                           (y   (location-y nl)))
                      (when (and (null (world-ref world x y))
                                 (multiply-successfulp))
                        (setf (world-ref world x y) 
                              (make-instance 'creature 
                                             :genome (creature-genome c))))))
                ;; EAT 
                (12 (let* ((nl        (gene->location (cpop c) location))
                           (x         (location-x nl))
                           (y         (location-y nl))
                           (neighbour (world-ref world x y)))
                      (when (not (null neighbour))
                        (if (battle c neighbour)
                            (world-null! world nl)
                            (world-null! world location)))))
                ;; HUMP
                (13 (let* ((nl        (gene->location (cpop c) location))
                           (x         (location-x nl))
                           (y         (location-y nl))
                           (neighbour (world-ref world x y))
                           (ol        (offspring-location location)))
                      (if neighbour
                          (setf (world-ref world (location-x ol) 
                                           (location-y ol))
                                (creature-reproduce c neighbour)))))
                (14 (let* ((nl        (gene->location (cpop c) location))
                           (x         (location-x nl))
                           (y         (location-y nl))
                           (neighbour (world-ref world x y)))
                      (when (null neighbour)
                        (world-null! world location)
                        (setf (world-ref world x y) c))))
                (15 (world-null! world location)))))
          T)
        NIL))
  

(defun run-world! (world)
  (let ((ws (world-size world)))
    (loop for x from 0 to ws
         do (loop for y from 0 to ws do
                 (run-creature! world x y))))
  world)

                 


(defun spawn-creature! (world genome)
  (let ((ws (world-size world)))
    (setf (world-ref world (random ws)
                     (random ws))
          (make-instance 'creature
                         :genome (string->genome genome)))))


(defun creature->color (creature)
  (let ((genome (creature-genome creature))
        (r 0)
        (g 0)
        (b 0))
    (loop for x from 0 to (1- (genome-length genome))
         do
         (let ((instr (genome-instr genome x)))
           (setf r (* instr 3.1415)
                 g (* instr 5.6345)
                 b (* instr 4.9321))))
    (values (mod r 1.0) (mod g 1.0) (mod b 1.0))))
                 
           

(defun world->png (world file)
  (let ((ws (world-size world)))
    (with-canvas (:width (* ws 2) :height (* ws 2))
      (set-rgb-fill 1 1 1)
      (clear-canvas)
      (set-line-width 2)
      (set-line-cap  :round)
      (loop 
         for x from 0 to ws
         do
           (loop for y from 0 to ws
              do
                (let ((c (world-ref world x y))
                      (x (* x 2))
                      (y (* y 2)))
                  (when c
                    (multiple-value-bind (r g b) (creature->color c)
                      (set-rgb-stroke r g b))
                    (move-to x y)
                    (line-to x y)
                    (stroke)))))
      (save-png file))))


(defun world->png-string (world)
  (let* ((stream (flexi-streams:make-in-memory-output-stream))
         (ws (world-size world)))
    (with-canvas (:width (* ws 2) :height (* ws 2))
      (set-rgb-fill 1 1 1)
      (clear-canvas)
      (set-line-width 2)
      (set-line-cap  :round)
      (loop 
         for x from 0 to ws
         do
           (loop for y from 0 to ws
              do
                (let ((c (world-ref world x y))
                      (x (* x 2))
                      (y (* y 2)))
                  (when c
                    (multiple-value-bind (r g b) (creature->color c)
                      (set-rgb-stroke r g b))
                    (move-to x y)
                    (line-to x y)
                    (stroke)))))
      (save-png-stream stream))
    (octets-to-string 
     (get-output-stream-sequence stream))))

(defun spawn-random-creature! (world)
  (let ((ws (world-size world)))
    (setf (world-ref world (random ws)
                     (random ws))
          (make-instance 'creature
                         :genome 
                         (make-array 10 :initial-contents (loop for x from 0 to 9 collect (random 16)))))))


;;; web-server
(defvar *acceptor* nil)
(defvar *world* (make-world 200))


(defun valid-genomep (genome)
    (if (scan "^([AGCT]{2}){1,16}$"genome)
        t 
        nil))

(define-easy-handler (spawn-handler :uri "/spawn") (genome)
  (if (valid-genomep genome)
      (progn
        (spawn-creature! *world* genome)
        "Creature submitted")
      "Invalid creature."))




(defvar *crunch-generations* 100)
(defvar *world-png-image* (world->png-string *world*))

(define-easy-handler (world-handler :uri "/world") ()
  (setf (hunchentoot:content-type*) "image/png")
  *world-png-image*)


(defvar *crunching-thread* nil)

(defun start-soup ()
  (setf *crunching-thread* 
        (sb-thread:make-thread (lambda ()
                                 (loop
                                    (sleep 2)
                                    (dotimes (n *crunch-generations*)
                                      (run-world! *world*))
                                    (setf *world-png-image*
                                          (world->png-string *world*))))))
  (hunchentoot:start (make-instance 'hunchentoot:acceptor :port 4242)))