Autómato celular 1D em LTK

Implementação em LTK de um autómato celular 1D

Depois de escrever esta entrada fiquei com a sensação de que o código precisava de uma representação mais apelativa para o resultado final em vez de uma lista cheia de zeros e uns (ver fim da página do link anterior).

Depois procurar uma maneira eficiente de fazer a coisa e porque as referências que encontrei eram todas em OpenGL, onde os manuais não são fáceis de digerir, resolvi implementar a representação gráfica em tk/tcl, nomeadamente em ltk — LTK - The Lisp Toolkit

Ao contrário dos manuais do OpenGL em que se usa CL, o manual do LTK está muito bem escrito. Com o código e o LTK faz-se

(defun ca-show (all-lst l)
  (with-ltk ()
    (let* ((c (make-instance 'canvas :background :white))
           (lst (car all-lst))
           (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 (square l (* i l) (* j l))))
                     (t
                      nil)))))
           (line-x
            (do ((i 1 (+ i 1)))
                ((= i  (+ 2 nx)))
              (create-line c (list l (* i l) (* l (+ 1 ny)) (* i l)))))
           (line-y
            (do ((j 1 (+ j 1)))
                ((= j (+ 2 ny)))
              (create-line c (list (* j l) l (* j l) (* l (+ 1 nx)))))))
      (pack c :expand nil :fill :both)
     )))


(defun square (l x y)
  (let ((xx (+ x l))
        (yy (+ y l)))
    (list xx yy
          (+ xx l) yy
          (+ xx l) (+ yy l)
          xx (+ yy l))))

e com um simples (ca-show (ca-run xboard xrules 50) 5) obtém-se a figura inicial.

Código completo:

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

(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 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-show (all-lst l)
  (with-ltk ()
    (let* ((c (make-instance 'canvas :background :white))
           (lst (car all-lst))
           (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 (square l (* i l) (* j l))))
                     (t
                      nil)))))
           (line-x
            (do ((i 1 (+ i 1)))
                ((= i  (+ 2 nx)))
              (create-line c (list l (* i l) (* l (+ 1 ny)) (* i l)))))
           (line-y
            (do ((j 1 (+ j 1)))
                ((= j (+ 2 ny)))
              (create-line c (list (* j l) l (* j l) (* l (+ 1 nx)))))))
      (pack c :expand nil :fill :both))))


(defun square (l x y)
  (let ((xx (+ x l))
        (yy (+ y l)))
    (list xx yy
          (+ xx l) yy
          (+ xx l) (+ yy l)
          xx (+ yy l))))

(setq xboard (make-board 300))
(setq xrules (nth-ca-rule 30))
(setq xpar-board (partition xboard 3 1))
(ca-run xboard xrules 15)

(ca-show (ca-run xboard xrules 100) 5)

Palavras chave/keywords: ltk, lisp, autómato celular 1D

Criado/Created: 10-05-2010 [00:00]

Última actualização/Last updated: 10-10-2022 [14:25]

Voltar à página inicial.