antlife.rkt

gistfile1.rkt

#lang racket
(require (except-in 2htdp/universe left right)
         2htdp/image)

(struct pos (x y) #:transparent)
(struct ant (pos dir) #:transparent)
(struct world (ant grid mode count) #:transparent)

(define freq 20)

(define dirs
  (let* ([i (overlay (triangle 8 "solid" "black")
                     (rectangle 10 10 'solid 'green))]
         [ph (make-placeholder #f)]
         [x `((up ,i 0 -1)
              (left ,(rotate 90 i) -1 0)
              (down ,(rotate 180 i) 0 1)
              (right ,(rotate 270 i) 1 0)
              . ,ph)])
    (placeholder-set! ph x)
    (make-reader-graph x)))

(define left cdr)
(define right cdddr)

(define (move-ant a)
  (match-define (ant (pos x y) d) a)
  (match (car d)
    [(list _ _ dx dy) (ant (pos (+ x dx) (+ y dy)) d)]))

(define (step w)
  (if (= (world-count w) 0)
      (life-step w)
      (match w
        [(world a b 'move c) (move a b c)]
        [(world a b 'turn c) (turn a b (- c 1))])))

(define (life-step w)
  (define (add-all-neighbours b)
    (for*/fold ([new-b b])
               ([p b])
      (for*/fold ([new-b new-b])
                 ([x (range -1 2)]
                  [y (range -1 2)])
        (set-add new-b (pos x y)))))
  
  (define (alive-neighbours p b)
    (match p
      [(pos x y)
       (define all
         (for*/list ([x (range (- x 1) (+ x 2))]
                     [y (range (- y 1) (+ y 2))])
           (pos x y)))
       (filter (λ (pp)
                 (and (set-member? b pp)
                      (not (equal? pp p))))
               all)]))
  
  (define (step b)
    (for/fold ([new-b b])
              ([p (add-all-neighbours b)])
      (define ncount (length (alive-neighbours p b)))
      (define was-alive? (set-member? b p))
      (define op (cond [(= ncount 3)  set-add]
                       [(and was-alive? (= ncount 2)) set-add]
                       [else set-remove]))
      (op new-b p)))
  
  (match w
    [(world a b m _) (world a (step b) m freq)]))

(define (move a b c)
  (world (move-ant a)
         b
         'turn
         c))

(define (turn a b c)
  (match-define (ant p d) a)
  (define-values (dir add/remove) 
    (if (set-member? b p)
        (values left set-remove)
        (values right set-add)))
  (world (ant p (dir d))
         (add/remove b p)
         'move
         c))

(define (draw w)
  (match-define (world (ant (pos x y) d) b _ _) w)
  (define i (draw-colors b (empty-scene 400 400)))
  (place-image (cadar d)
               (* x 10)
               (* y 10)
               i))

(define (draw-colors b scene)
  (for/fold ([i scene])
            ([bpos b])
    (place-image (rectangle 10 10 'solid 'black)
                 (* (pos-x bpos) 10)
                 (* (pos-y bpos) 10)
                 i)))

(big-bang (world (ant (pos 20 20) (right dirs))
                 (set)
                 'move
                 freq)
          (on-tick step 1/20)
          (to-draw draw))