PasteRack.org
Paste # 51739
2019-02-19 21:14:52

Fork as a new paste.

Paste viewed 321 times.


Embed:

towards a game of life gui app

  1. #lang typed/racket
  2.  
  3. (require typed/racket/gui)
  4.  
  5. (provide node                          ; Type: A struct, recursive with Quadtree, representing a non-null record with four children.
  6.          Quadtree                      ; Type: Union type, either a null record or a node.
  7.          get-node-coords               ; Function: A null-gated function to provide the coordinates associated with a node.
  8.          get-node-child                ; Function: A null-gated function to provide a child under a node in a particular Direction.
  9.          Direction                     ; Type: A union type -- either a function that returns a child node, or the symbol 'self.
  10.          coordinate                    ; Type: A struct of X Y cartesian coordinates.
  11.          coordinate-x                  ; Function: Struct accessor for coordinates.
  12.          coordinate-y                  ; Function: Struct accessor for coordinates.
  13.          coordinate-compare            ; Function: Return a Direction when given two points.
  14.          quadtree-member?              ; Function: A predicate that returns #t iff given Quadtree contains given coordinate.
  15.          in-range?                     ; Function: A predicate that given x y z returns #t iff x <= z <= y.
  16.          neighbor?                     ; Function: A predicate that returns #t iff two coordinates are neighbors.
  17.          overlapping-quadrants         ; Function: Returns a list of Directions overlapping neighbor points to a given coordinate.
  18.          quadtree-neighbors            ; Function: Returns a list of coordinates from the Quadtree neighboring a given coordinate.
  19.          descendant-coordinates        ; Function: Return coordinates of a node and all its descendants.
  20.          quadtree-fold                 ; Function: Given a Quadtree and a list of coordinates, recursively insert coordinates and return resultant quadtree.
  21.          quadtree-nuke                 ; Function: Given a Quadtree and a list of coordinates, recursively delete coordinates and return resultant quadtree.
  22.          quadtree-insert               ; Function: Given a Quadtree and a coordinate, return a Quadtree with the new coordinate inserted.
  23.          quadtree-delete               ; Function: Given a Quadtree and a coordinate, return a Quadtree with the coordinate deleted. Nonrecursive wrapper for cps.
  24.          cape                          ; Type: A struct containing a Quadtree and a list of orphaned coordinates.
  25.          cps                           ; Function: Recursively delete a coordinate from a Quadtree, returning a cape containing the new Quadtree and a list of any orphaned coordinates.
  26.          print-all-coords              ; Convenience function to print all the coordinates from a list of coordinates.
  27.          evolve)                       ; Main event loop for gui.
  28.  
  29.  
  30. (current-output-port (open-output-nowhere))
  31.  
  32. (struct node ([ NE : Quadtree ]
  33.               [ NW : Quadtree ]
  34.               [ SW : Quadtree ]
  35.               [ SE : Quadtree ]
  36.               [ coords : coordinate]))
  37.  
  38. (define-type Quadtree (U Null node))
  39.  
  40. (struct coordinate ([x : Integer] [y : Integer]))
  41.  
  42. ; A null-checking wrapper for node-coords.
  43. (define-syntax-rule (get-node-coords quadtree)
  44.   (cond [(null? quadtree) (raise "get-node-coords cannot be called on a null Quadtree.")]
  45.         [else (node-coords quadtree)]))
  46.  
  47. ; A null-checking wrapper for node-<Direction>.
  48. (: get-node-child (-> Quadtree (-> node Quadtree) Quadtree))
  49. (define (get-node-child quadtree direction)
  50.   (cond [(null? quadtree) (raise "get-node-child cannot be called on a null Quadtree.")]
  51.         [else (direction quadtree)]))
  52.  
  53. (define-type Direction (U (-> node Quadtree) 'self))
  54.  
  55. (: lexicographical-coordinate-sort (-> (Listof coordinate) (Listof coordinate)))
  56. (define (lexicographical-coordinate-sort coord-list)
  57.   (sort coord-list
  58.         (λ ([c1 : coordinate] [c2 : coordinate])
  59.           (let ([c1-x (coordinate-x c1)] [c1-y (coordinate-y c1)] [c2-x (coordinate-x c2)] [c2-y (coordinate-y c2)])
  60.             (cond [(< c1-x c2-x) #t]
  61.                   [(and (= c1-x c2-x) (< c1-y c2-y)) #t]
  62.                   [else #f])))))
  63.  
  64. (: in-range? (-> Integer Integer Integer Boolean))
  65. (define (in-range? x y z)(and (<= x z) (>= y z)))
  66.  
  67. ; The comparison function discerns which quadrant below a node in which to categorize a set of coordinates.
  68. ; The Finkel and Bentley paper uses a convention by which, for those points lying on cardinal directions,
  69. ; Quadrants I and III are "open", while II and IV are "closed." It seems to me that this will inevitably
  70. ; result in an unbalanced tree, so my implementation gives each quadrant a cardinal direction.
  71.  
  72. (define-syntax-rule (coordinate-compare a b)
  73.   (let ([a-x : Integer (coordinate-x a)]
  74.         [a-y : Integer (coordinate-y a)]
  75.         [b-x : Integer (coordinate-x b)]
  76.         [b-y : Integer (coordinate-y b)])
  77.     (cond [(and (<= a-x b-x) (<  a-y b-y)) node-NE]
  78.           [(and (>  a-x b-x) (<= a-y b-y)) node-NW]
  79.           [(and (>= a-x b-x) (>  a-y b-y)) node-SW]
  80.           [(and (<  a-x b-x) (>= a-y b-y)) node-SE]
  81.           [(and (= a-x b-x) (= a-y b-y)) 'self]
  82.           ; If you somehow raise this error, I did not account for something.
  83.           ; I am confident the other options are exhaustive.
  84.           [else (raise "coordinate-compare should never return this!")])))
  85.  
  86.  
  87. (: quadtree-member? (-> Quadtree coordinate Boolean))
  88. (define (quadtree-member? quadtree coords)
  89.   (cond [(null? quadtree) #f]
  90.         [else (let ([quadrant (coordinate-compare (node-coords quadtree) coords)])
  91.                 (cond [(equal? quadrant 'self) #t]
  92.                       [else (quadtree-member? (get-node-child quadtree quadrant) coords)]))]))
  93.  
  94. (define-syntax-rule (neighbor? c1 c2)
  95.   (let ([x1 : Integer (coordinate-x c1)]
  96.         [y1 : Integer (coordinate-y c1)]
  97.         [x2 : Integer (coordinate-x c2)]
  98.         [y2 : Integer (coordinate-y c2)])
  99.     (and
  100.      (and (in-range? (- x1 1) (+ x1 1) x2)
  101.           (in-range? (- y1 1) (+ y1 1) y2))
  102.      (nand (equal? x1 x2) (equal? y1 y2)))))
  103.  
  104. (: overlapping-quadrants (-> coordinate coordinate (Listof (-> node Quadtree))))
  105. (define (overlapping-quadrants c1 c2)
  106.   (let* ([x1 : Integer (coordinate-x c1)]
  107.          [y1 : Integer (coordinate-y c1)]
  108.          [x2 : Integer (coordinate-x c2)]
  109.          [y2 : Integer (coordinate-y c2)]
  110.          [NE (if (and (>= (+ x2 1) x1) (>  (+ y2 1) y1)) node-NE null)]
  111.          [NW (if (and (<  (- x2 1) x1) (>= (+ y2 1) y1)) node-NW null)]
  112.          [SW (if (and (<= (- x2 1) x1) (<  (- y2 1) y1)) node-SW null)]
  113.          [SE (if (and (>  (+ x2 1) x1) (<= (- y2 1) y1)) node-SE null)])
  114.     ((inst filter (U Null (-> node Quadtree)) (-> node Quadtree)) procedure? (list NE NW SW SE))))
  115.  
  116. ; For now I'll just address the case I'll be using in Game of Life, and look for direct neighbors.
  117. (: quadtree-neighbors (-> Quadtree coordinate Integer))
  118. (define (quadtree-neighbors quadtree coords)
  119.   (cond [(null? quadtree) 0]
  120.         [else
  121.          (let ([quadrants (overlapping-quadrants (node-coords quadtree) coords)]
  122.                [am-neighbor : Integer (if (neighbor? (node-coords quadtree) coords) 1 0)])
  123.            (+ (foldl + 0 (map
  124.                           (λ ([direction : (-> node Quadtree)])
  125.                             (quadtree-neighbors (direction quadtree) coords)) quadrants)) am-neighbor))]))
  126.  
  127. (: descendant-coordinates (-> Quadtree (Listof coordinate)))
  128. (define (descendant-coordinates quadtree)
  129.   (cond [(null? quadtree) null]
  130.         [else (let ([coords (list (get-node-coords quadtree))])
  131.                 (append coords
  132.                         (append-map
  133.                          (λ ([direction : (-> node Quadtree)])
  134.                            (descendant-coordinates (direction quadtree)))
  135.                          (list node-NE node-NW node-SW node-SE))))]))
  136.  
  137. ; Deletion
  138. ; Given a null Quadtree, return it unchanged (it's already gone.)
  139. ; At the top of the recursion stack, take any remaining orphans and insert them into the new Quadtree.
  140. ; Quadtree-delete is a wrapper function whose job is to keep the orphans an internal matter.
  141. ; It calls the recursive cps function, which performs the deletion and hands up a 'cape' struct
  142. ; containing a list of orphaned nodes that need to be reinserted to the quadtree.
  143. (: quadtree-delete (-> Quadtree coordinate Quadtree))
  144. (define (quadtree-delete quadtree coords)
  145.   (let* ([crime-scene-and-orphans (cps quadtree coords)]
  146.          [crime-scene (cape-quadtree crime-scene-and-orphans)]
  147.          [orphans (cape-orphans crime-scene-and-orphans)])
  148.     (quadtree-fold crime-scene orphans)))
  149.  
  150. ; The best part is that after I implemented all this I realized I don't need deletion for Game of Life lol
  151. (: cps (-> Quadtree coordinate cape))
  152. (define (cps quadtree coords)
  153.   (cond [(null? quadtree) (cape null null)] ; Stop, he's already dead
  154.         [(equal? 'self (coordinate-compare (get-node-coords quadtree) coords)) ; Do the deed,
  155.          (cape null (rest (descendant-coordinates quadtree)))]                 ; but rescue the orphans.
  156.         [else
  157.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]
  158.                 [r (λ ([direction : (-> node Quadtree)]) (if (equal? quadrant direction)
  159.                                                              (cps (get-node-child quadtree direction) coords)
  160.                                                              (cape (get-node-child quadtree direction) null)))]
  161.                 [NE (r node-NE)] [NW (r node-NW)] [SW (r node-SW)] [SE (r node-SE)]
  162.                 [gather-orphans (λ ([cape-list : (Listof cape)]) (append-map cape-orphans cape-list))]
  163.                 [orphans (gather-orphans (list NE NW SW SE))])
  164.            (cape (node
  165.                   (cape-quadtree NE)
  166.                   (cape-quadtree NW)
  167.                   (cape-quadtree SW)
  168.                   (cape-quadtree SE)
  169.                   (get-node-coords quadtree)) orphans))]))
  170.  
  171. (: quadtree-nuke (-> Quadtree (Listof coordinate) Quadtree))
  172. (define (quadtree-nuke quadtree coord-list)
  173.   (cond [(null? coord-list) quadtree]
  174.         [else (quadtree-nuke (quadtree-delete quadtree (first coord-list)) (rest coord-list))]))
  175.  
  176. (: quadtree-fold (-> Quadtree (Listof coordinate) Quadtree))
  177. (define (quadtree-fold quadtree coord-list)
  178.   (cond [(null? coord-list) quadtree]
  179.         [else (quadtree-fold (quadtree-insert quadtree (first coord-list)) (rest coord-list))]))
  180.  
  181. (: quadtree-fold-optimized (-> Quadtree (Listof coordinate) Quadtree))
  182. (define (quadtree-fold-optimized quadtree coord-list)
  183.   (quadtree-fold quadtree (lexicographical-coordinate-sort coord-list)))
  184.  
  185.  
  186. (: quadtree-insert (-> Quadtree coordinate node))
  187. (define (quadtree-insert quadtree coords)
  188.   (cond [(null? quadtree) (node null null null null coords)]
  189.         [(procedure? (coordinate-compare (get-node-coords quadtree) coords))
  190.          (let* ([quadrant (coordinate-compare (get-node-coords quadtree) coords)]
  191.                 [r (λ ([direction : (-> node Quadtree)])
  192.                      (if (equal? quadrant direction)
  193.                          (quadtree-insert (get-node-child quadtree direction) coords)
  194.                          (get-node-child quadtree direction)))])
  195.            (node
  196.             (r node-NE)
  197.             (r node-NW)
  198.             (r node-SW)
  199.             (r node-SE)
  200.             (get-node-coords quadtree)))]
  201.         [else quadtree]))
  202.  
  203.  
  204. ; Capes are constructs that let me hand up orphans as needed from the recursive part of the deletion mechanism.
  205. (struct cape ([quadtree : Quadtree]
  206.               [orphans : (Listof coordinate)]))
  207.  
  208. ; constants. never enough constants
  209. (define cell-scale 8)
  210. (define canvas-size 800)
  211.  
  212. (define living-cells null)
  213.  
  214. ; Given a coordinate and a Quadtree, determine if it survives.
  215. (: determine-cell-state (-> Quadtree coordinate Boolean))
  216. (define (determine-cell-state population cell)
  217.   (let ([living-neighbors (quadtree-neighbors population cell)]
  218.         [orig-state (quadtree-member? population cell)])
  219.     (cond
  220.       [(or (or (< (coordinate-x cell) -5) (> (coordinate-x cell) (+ (/ (send frame get-width) cell-scale) 5)))
  221.            (or (< (coordinate-y cell) -5) (> (coordinate-y cell) (+ (/ (send frame get-height) cell-scale) 5)))) #f] ;pesticide
  222.       [(< living-neighbors 2) #f]             ; if the cell has fewer than 2 neighbors, it dies.
  223.       [(equal? living-neighbors 3) #t]        ; if the cell has exactly 3 neighbors, it comes to life.
  224.       [(> living-neighbors 3) #f]             ; if the cell has more than 3 neighbors, it dies.
  225.       [else orig-state])))
  226.  
  227.  
  228. (: tick (-> Quadtree Quadtree))
  229. (define (tick living-cells)
  230.   (let ([cell-list (descendant-coordinates living-cells)])
  231.     (quadtree-fold null
  232.                    (get-livers cell-list living-cells null null))))
  233.  
  234. (: get-livers (-> (Listof coordinate) Quadtree Quadtree (Listof coordinate) (Listof coordinate)))
  235. (define (get-livers cell-list living-cells [seen null] [acc null])
  236.   (cond [(null? cell-list) acc]
  237.         [else
  238.          (let* ([cell (first cell-list)]
  239.                 [neighbors (neighbor-coords cell)]
  240.                 [unseen (filter (λ ([n : coordinate]) (not (quadtree-member? seen n))) neighbors)]
  241.                 [alive? (curry determine-cell-state living-cells)])
  242.            (get-livers (rest cell-list) living-cells (quadtree-fold seen unseen) (append (filter alive? unseen) acc)))]))
  243.  
  244. ; I'd like to find a cleaner way to do this.
  245. (: neighbor-coords (-> coordinate (Listof coordinate)))
  246. (define (neighbor-coords coordinate)
  247.   (let ([x : Integer (coordinate-x coordinate)]
  248.         [y : Integer (coordinate-y coordinate)])
  249.     (append-map (curry coordmap x) (range (- y 1) (+ y 2)))))
  250.  
  251. ; give all the ys for an x
  252. (: coordmap (-> Integer Integer (Listof coordinate)))
  253. (define (coordmap x y)
  254.   (map (λ ([z : Integer]) (coordinate z y))
  255.        (range (- x 1) (+ x 2))))
  256.  
  257. (define better-frame% (class frame% (super-new)
  258.                         (define (on-close)
  259.                           (exit))
  260.                         (augment on-close)))
  261.  
  262. (define frame (new better-frame% [label "Conway's Game of Life"] [width canvas-size] [height canvas-size]))
  263.  
  264. (: new-mouse-cells (Listof coordinate))
  265. (define new-mouse-cells null)
  266. (: kill-mouse-cells (Listof coordinate))
  267. (define kill-mouse-cells null)
  268.  
  269. (define better-canvas% (class canvas%
  270.                          (define/override (on-char ev)
  271.                            (let ([kc (send ev get-key-code)])
  272.                              (cond [(eq? kc #\1) (set! cell-color "green")]
  273.                                    [(eq? kc #\2) (set! cell-color "red")]
  274.                                    [(eq? kc #\3) (set! cell-color "orange")]
  275.                                    [(eq? kc #\4) (set! cell-color "yellow")]
  276.                                    [(eq? kc #\5) (set! cell-color "blue")]
  277.                                    [(eq? kc #\6) (set! cell-color "indigo")]
  278.                                    [(eq? kc #\7) (set! cell-color "violet")])))
  279.                          (define/override (on-event event)
  280.                            (cond [(or (send event button-down? 'right) (send event get-right-down))
  281.                                   (set! kill-mouse-cells (neighbor-coords (coordinate (floor (/ (send event get-x) cell-scale)) (floor (/ (send event get-y) cell-scale)))))]
  282.                                  [(or (send event button-down? 'left) (send event get-left-down))
  283.                                   (set! new-mouse-cells (list (coordinate (floor (/ (send event get-x) cell-scale)) (floor (/ (send event get-y) cell-scale)))
  284.                                                               (coordinate (+ (floor (/ (send event get-x) cell-scale)) 1) (floor (/ (send event get-y) cell-scale)))
  285.                                                               (coordinate (- (floor (/ (send event get-x) cell-scale)) 1) (floor (/ (send event get-y) cell-scale)))
  286.                                                               ))]))(super-new)))
  287.  
  288.  
  289. (define canvas (new better-canvas% [parent frame]
  290.                     [paint-callback
  291.                      (λ (c dc)
  292.                        (send dc set-pen "black" 1 'transparent)
  293.                        (send dc set-brush "black" 'solid)
  294.                        (send dc draw-rectangle 0 0 (send frame get-width) (send frame get-height)))]))
  295.  
  296. (: cell-color String)
  297. (define cell-color "green")
  298.  
  299. ; draww
  300. (: recursidraw (-> (Instance DC<%>) (Listof coordinate) (Instance DC<%>)))
  301. (define (recursidraw dc cells)
  302.   (cond
  303.     [(empty? cells) dc]
  304.     [else   (let ([cell : coordinate (first cells)])
  305.               (send dc set-brush cell-color 'solid)
  306.               (send dc set-pen "black" 1 'solid)
  307.               (send dc draw-rectangle
  308.                     (* cell-scale (coordinate-x cell))
  309.                     (* cell-scale (coordinate-y cell)) cell-scale cell-scale)
  310.               (recursidraw dc (rest cells)))]))
  311.  
  312. (: print-all-coords (-> (Listof coordinate) Void))
  313. (define (print-all-coords coord-list)
  314.   ((inst for-each coordinate)
  315.    (λ (coord) (fprintf (current-output-port)
  316.                        "X: ~s Y: ~s\n"
  317.                        (coordinate-x coord)
  318.                        (coordinate-y coord))) coord-list))
  319.  
  320. (: evolve (-> Quadtree Any))
  321. (define (evolve quadtree)
  322.   (let ([coord-list (descendant-coordinates quadtree)]
  323.         [dc (send canvas get-dc)]
  324.         [x null]
  325.         [updated-quadtree (quadtree-nuke (quadtree-fold quadtree new-mouse-cells) kill-mouse-cells)])
  326.     (set! new-mouse-cells null)
  327.     (set! kill-mouse-cells null)
  328.     (send canvas suspend-flush)
  329.     (send canvas on-paint)
  330.     (recursidraw dc coord-list)
  331.     (send dc set-text-foreground "blue")
  332.     (send dc draw-text "rob@robertlavery.com" (- (send frame get-width) 200) (- (send frame get-height) 90))
  333.     (send canvas resume-flush)
  334.     (send canvas flush)
  335.     (sleep/yield 0.01)
  336.     (evolve (tick updated-quadtree))))
  337.  
  338. (void
  339.  (send frame show #t)
  340.  (evolve living-cells))

=>