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

Aqui fica a nova versão do mesmo.

Screenshot da janela de LTK da evolução da regra 30.

(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: "))
           (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
                              :height 1
                              :command (lambda () (clear c))))
           (b-run (make-instance 'button
                              :text "Run"
                              :master f
                              :width 4
                              :height 1
                              :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