Land of Lisp : Chapter 10

evolution.scm

#!/usr/local/bin/gosh

;;; 本とshiroさんのコードを写経しつつ少し改造してあります。
;;; https://github.com/shirok/Gauche-LoL/blob/master/evolution.scm
;;; https://github.com/shirok/Gauche-LoL/blob/master/evolution-color.scm

(use srfi-1) ; list-tabulate
(use srfi-27) ; random-integer
(use gauche.parameter)
(use gauche.record)
(use gauche.sequence)
(use gauche.process)
(use gauche.parseopt)

(define-constant +GENES_LENGTH+ 8)

(define *plants* (make-hash-table 'equal?))
(define *width* (make-parameter 100))
(define *height* (make-parameter 30))
(define *jungle* (make-parameter '(45 10 10 10)))
(define *plant-energy* (make-parameter 80) )

(define (random-plant! left top width height)
  (let1 pos (cons (+ left (random-integer width))
                  (+ top (random-integer height)))
    (hash-table-put! *plants* pos #t)))

(define (add-plants!)
  (apply random-plant! (*jungle*))
  (random-plant! 0 0 (*width*)(*height*)))

(define-record-type animal #t #t
  (x)(y)(energy)(dir)(genes))

(define *animals*
  (list (make-animal
         (ash (*width*) -1)
         (ash (*height*) -1)
         1000
         0
         (list-tabulate
          +GENES_LENGTH+
          (^_ (+ 1 (random-integer 10)))))))

(define (move! animal)
  (let ((dir (animal-dir animal))
        (x (animal-x animal))
        (y (animal-y animal)))
    (set! (animal-x animal)
          (modulo (+ x (cond ((and (>= dir 2)(< dir 5)) 1)
                             ((or (= dir 1)(= dir 5)) 0)
                             (else -1))
                     (*width*))
                  (*width*)))
    (set! (animal-y animal)
          (modulo (+ y (cond ((and (>= dir 0)(< dir 3)) -1)
                             ((and (>= dir 4)(< dir 7)) 1)
                             (else 0))
                     (*height*))
                  (*height*)))
    (dec! (animal-energy animal))))

(define (turn! animal)
  (let1 x (random-integer (apply + (animal-genes animal)))
    (define (angle genes x)
      (let rec ((genes genes)(x x)(acc 0))
        (let1 xnu (- x (car genes))
          (if (< xnu 0)
              acc
              (rec (cdr genes) xnu (+ acc 1))))))
    (set! (animal-dir animal)
          (modulo (+ (animal-dir animal)
                     (angle (animal-genes animal) x))
                  +GENES_LENGTH+))))

(define (eat! animal)
  (let1 pos (cons (animal-x animal)(animal-y animal))
    (when (hash-table-get *plants* pos #f)
      (inc! (animal-energy animal)(*plant-energy*))
      (hash-table-delete! *plants* pos))))

(define *reproduction-energy* (make-parameter 200))

(define (reproduce! animal)
  (let1 e (animal-energy animal)
    (when (>= e (*reproduction-energy*))
      (set! (animal-energy animal)(ash e -1))
      (let ((animal-nu (make-animal (animal-x animal)
                                    (animal-y animal)
                                    (animal-energy animal)
                                    (animal-dir animal)
                                    (list-copy
                                     (animal-genes animal))))
            (mutation  (random-integer +GENES_LENGTH+)))
        (update! (~ animal-nu 'genes mutation)
                 (^v (max 1 (+ v (random-integer 3) -1))))
        (push! *animals* animal-nu)))))

(define (update-world!)
  (set! *animals* (remove! (^(animal)(<= (animal-energy animal) 0))
                           *animals*))
  (dolist (animal *animals*)
    (turn! animal)
    (move! animal)
    (eat! animal)
    (reproduce! animal))
  (add-plants!))

(define (draw-world)
  (dotimes (y (*height*))
    (newline)
    (display "|")
    (dotimes (x (*width*))
      (display (cond ((find (^(animal) (and (= (animal-x animal) x)
                                            (= (animal-y animal) y)))
                            *animals*)
                      => (^a (with-color #\M (animal-genes a))))
                     ((hash-table-get *plants* (cons x y) #f) #\*)
                     (else #\space))))
    (display "|")
    ))

(define *hue-vecs*
  '((255 0 0)
    (255 191 0)
    (128 255 0)
    (0 255 64)
    (0 255 255)
    (0 64 255)
    (128 0 255)
    (255 0 191)))

(define *terminal-colors*
  '(((0 0 0) "30")
    ((205 0 0) "31")
    ((0 205 0) "32")
    ((205 205 0) "33")
    ((0 0 238) "34")
    ((205 0 205) "35")
    ((0 205 205) "36")
    ((229 229 229) "37")
    ((127 127 127) "30;1")
    ((255 0 0) "31;1")
    ((0 255 0) "32;1")
    ((255 255 0) "33;1")
    ((92 92 255) "34;1")
    ((255 0 255) "35;1")
    ((0 255 255) "36;1")
    ((255 255 255) "37;1")))

(define (gene-color gene)
  (let1 factor (/. (apply + gene))
    (define (col picker)
      (clamp (reduce + 0 (map (^(c g)(*. (picker c) g factor))
                              *hue-vecs* gene))
             0 255))
    (list (col car) (col cadr) (col caddr))))

(define (find-closest-terminal-color color)
  (define (distance c1 c2)
    (apply + (map (^p (expt (- (p c1) (p c2)) 2)) (list car cadr caddr))))
  (find-min *terminal-colors* :key (^e (distance (car e) color))))

(define (with-color char gene)
  (let1 entry (find-closest-terminal-color (gene-color gene))
    (format "\u001b[~am~a\u001b[0m" (cadr entry) char)))

(random-source-randomize! default-random-source)

(define (evolution :optional
                   (width #f)(height #f)(jungle #f)(plant-energy #f)
                   (reproduction-energy #f))
  (parameterize ((*width* (or width (*width*)))
                 (*height* (or height (*height*)))
                 (*jungle* (or jungle (*jungle*)))
                 (*plant-energy*  (or plant-energy (*plant-energy*)))
                 (*reproduction-energy* (or reproduction-energy (*reproduction-energy*))))
    (read-line)
    (let loop ()
      (draw-world)
      (newline)
      (let1 str (read-line)
        (unless (equal? str "quit")
          (if-let1 x (string->number str)
                   (dotimes (i x)
                     (update-world!)
                     (when (zero? (modulo i 1000))
                       (display #\.)(flush)))
                   (update-world!))
          (loop))))))

(define (tput . args)
  (run-process `(tput ,@args)))

(define (get-tput-val . args)
  (process-output->string `(tput ,@args)))

(define (usage cmd)
  (print "usage: " cmd "[option ...]")
  (print "  options:")
  (print "    w|width  : world width (default: terminal width - 2)")
  (print "    h|height : world height (default: terminal height - 1)")
  (print "    j|jungle : jungle location and size (top left width height)")
  (print "               (default (45 10 10 10)) ")
  (print "    p|plant-energy : (default 80)")
  (print "    r|reproduction-energy : (default 200)")
  (exit))

(define (main args)
  (let-args (cdr args)
      ((help "h|help" => (cut usage (car args)))
       (width "w|width=i" (- (string->number (get-tput-val 'cols)) 2))
       (height "h|height=i" (- (string->number (get-tput-val 'lines)) 1))
       (jungle "j|jungle=e" '(45 10 10 10))
       (plant-energy "p|plant-energy=i" 80)
       (reproduction-energy "r|reproduction-energy=i" 200)
       (else (opt . _)
             (print "Unknown option : " opt)
             (usage (car args)))
       . rest)
    (evolution width height jungle plant-energy reproduction-energy)))