Autómato celular 1D em LTK (act.)

Aqui fica a nova versão do mesmo.

;; Copyright (C) 2010  Tiago Charters de Azevedo <tca@diale.org>

;; 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/>.

(defpackage :ca-ltk
  (:use :common-lisp :ltk)
  (:export ca-run-ltk))

(in-package :ca-ltk)

(defun to-bin (x)
  (cond ((= 0 x)
         0)
        (t
         (let* ((q (floor (/ x 2.)))
                (r (- x (* 2 q))))
           (cond ((= q 0)
           '(1))
                 (t
                  (cons r (to-bin q))))))))

(defun zeros (n)
  (cond ((= n 0) nil)
        (t
         (cons '0 (zeros (- n 1))))))

(defun length-to-bin (n x)
  (cond ((= n 0)
         0)
        (t
         (append (to-bin x) (zeros (- n (length (to-bin x))))))))

(defun dec-to-b (x b)
  (cond ((= x 0)
         0)
        (t
         (let* ((q (floor (/ x (* b 1.0))))
                (r (- x (* b q))))
           (cond ((= q 0)
                  1)
                 (t
                  (cons r (dec-to-b q b))))))))

(defun nest-car (lst n)
  "?anti-cdr?"
  (cond (lst
         (let ((m (- n 1)))
           (cond ((= m 0)
                  (list (car lst)))
                 (t
                  (cons (car lst) (nest-car (cdr lst) (- n 1)))))))
        (t nil)))

(defun partition1 (lst n m)
  (cond ((<= m (length lst))
         (cond (lst
                (cons (nest-car lst n) (partition1 (nthcdr m lst) n m)))
               (t nil)))
        (t nil)))

(defun partition (lst n m)
  (mapcan #'(lambda (x) (and (= n (length x)) (list x)))
          (partition1 lst n m)))



(defun nth-ca-rule (n)
  (labels ((3-tuple (bin-n 3tuple)
             (cond (3tuple
                   (cons
                    (list  (car 3tuple) (car bin-n))
                    (3-tuple (cdr bin-n) (cdr 3tuple)))))))
    (let* ((bin-x (to-bin n))
           (bin-n  (length-to-bin 8 n)))
      (3-tuple bin-n '((0 0 0) (0 0 1) (0 1 0) (0 1 1) (1 0 0) (1 0 1) (1 1 0) (1 1 1))))))

(defun make-board (m)
  (concatenate 'list
               nil
               (zeros (floor (/ m 2.0)))
               '(1)
               (zeros (floor (/ m 2.0)))))

(defun ca-apply-car (3tuple rules)
  (cond ((equal 3tuple (caar rules))
         (cadar rules))
        (t
         (ca-apply-car 3tuple (cdr rules)))))

(defun ca-apply (board rules)
  (let ((first-cell (list (car board)))
        (last-cell (list (car (reverse board)))))
    (concatenate 'list first-cell
          (mapcar #'(lambda (x)
                      (ca-apply-car x rules)) (partition board 3 1))
          last-cell)))

(defun ca-run (board rules n)
  (cond ((= n 0)
         nil)
        (t
         (cons board (ca-run (ca-apply board rules) rules (- n 1))))))

(defun ca-run-ltk()
  (labels ((make-square (l x y)
             (let ((xx (+ x l))
                   (yy (+ y l)))
               (list xx yy
                     (+ xx l) yy
                     (+ xx l) (+ yy l)
                     xx (+ yy l)))))
  (with-ltk ()
    (wm-title *tk* "Cellular automata")
    (let* ((f (make-instance 'frame))
           (f-values (make-instance 'frame))
           (tag-rule (make-instance 'label :master f-values :text "CA-rule (<255): "))
           (c (make-instance 'canvas
                             :background :white
                             :width 1000
                             :height 500))
           (ca-rule (make-instance 'text
                                  :master f-values
                                  :width 4
                                  :height 1
                                  :background :white))
           (ca-with (make-instance 'text
                                   :master f-values
                                   :width 4
                                   :height 1
                                   :background :white))
           (ca-iter (make-instance 'text
                                   :master f-values
                                   :width 4
                                   :height 1
                                   :background :white))
           (b-clear (make-instance 'button
                              :text "Clear"
                              :master f
                              :width 4
                              :command (lambda () (clear c))))
           (b-run (make-instance 'button
                              :text "Run"
                              :master f
                              :width 4
                              :command (lambda ()
                                         (let* ((board-dim 200)
                                                (nca-rule (parse-integer (text ca-rule)))
                                                (n-iter 96)
                                                (l 5)
                                                (all-lst (ca-run (make-board board-dim)
                                                                 (nth-ca-rule nca-rule)
                                                                 n-iter))
                                                (ny (length (car all-lst)))
                                                (nx (length all-lst))

                                                (squares
                                                 (do ((j 0 (+ j 1)))
                                                     ((= j nx))
                                                   (do ((i 0 (+ i 1)))
                                                       ((= i ny))
                                                     (cond ((= 1 (car (nthcdr i (car (nthcdr j all-lst)))))
                                                            (create-polygon c (make-square l (* i l) (* j l))))
                                                           (t
                                                            nil)))))))))))
      (pack c :side :top :expand nil)
      (pack f-values :side :left :expand nil :fill :none)
      (pack tag-rule :side :left :expand t :fill :both)
      (pack ca-rule :side :left :expand t :fill :both)
      (pack f :side :right :expand t :fill :both)
      (pack b-run :side :right)
      (pack b-clear :side :right)))))

E o package:ca-ltk.lisp

Voltar à página inicial.

(c) Tiago Charters de Azevedo