Game of Life in Racket's math/arrays and SRFI 231 Bradley Lucier 18 Jan 2022 00:03 UTC

Jens Axel asked about array usage on the Racket Discourse channel and
Alex Harsányi built the Game of Life using the math/arrays library of
Racket in this post:

https://racket.discourse.group/t/game-of-life-using-math-array/584

I thought it might be interesting do something similar with SRFI 231.  I
got pretty far into the weeds, but I think one can get an idea of
programming strategies and performance.

My strategy is to pad out the original two-dimensional array with an
extra row on top and bottom and an extra column on left and right.

One way is to copy the input array to a new specialized array;

(begin
   (pp "specialized array-engorge")

   (define (array-engorge a)
     ;; Extends a periodically one row and column on either side
     ;; Assumes a has domain (make-interval (vector m n))
     (let* ((domain     (array-domain a))
            (m          (interval-upper-bound domain 0))
            (n          (interval-upper-bound domain 1))
            (new-domain (interval-dilate domain '#(-1 -1) '#(1 1)))
            (result     (make-specialized-array new-domain
(array-storage-class a))))
       ;; Assign the middle block
       (array-assign! (array-extract result domain) a)
       ;; Assign the left-most and right-most columns
       (let* ((columns  (array-curry (array-permute result '#(1 0)) 1))
              (columns_ (array-getter columns)))
         (array-assign! (columns_ n)  (columns_ 0))
         (array-assign! (columns_ -1) (columns_ (- n 1))))
       ;; Assign the top and bottom rows
       (let* ((rows  (array-curry result 1))
              (rows_ (array-getter rows)))
         (array-assign! (rows_ m)  (rows_ 0))
         (array-assign! (rows_ -1) (rows_ (- m 1))))
       result)))

A simpler way is to return a generalized array that just messes with the
addressing:

(begin
   (pp "generalized array-engorge")

   (define (array-engorge a)
     (let* ((domain     (array-domain a))
            (m          (interval-upper-bound domain 0))
            (n          (interval-upper-bound domain 1))
            (a_         (array-getter a)))
       (make-array (interval-dilate domain '#(-1 -1) '#(1 1))
                   (lambda (i j)
                     (a_ (modulo i m) (modulo j n)))))))

I started doing some timings and started with

(define (neighbor-count a)
   (let* ((big-a      (array-engorge a))
          (domain     (array-domain a))
          (translates (map (lambda (translation)
                             (array-extract (array-translate big-a
translation) domain))
                           '(#(1 0) #(0 1) #(-1 0) #(0 -1)
                             #(1 1) #(1 -1) #(-1 1) #(-1 -1)))))
     (apply array-map + translates)))

but apply was used all over the place internally because there are 8
arrays and performance was abysmal for anything over 4 arrays.  I then
tried:

(define (neighbor-count a)
   (let* ((big-a      (array-engorge a))
          (domain     (array-domain a))
          (translates (map (lambda (translation)
                             (array-extract (array-translate big-a
translation) domain))
                           '(#(1 0) #(0 1) #(-1 0) #(0 -1)
                             #(1 1) #(1 -1) #(-1 1) #(-1 -1)))))
     (array-map
      (+
      (apply array-map + (take translates 4))
      (apply array-map + (drop translates 4)))))

which was better, but the generic + takes a general number of arguments
so again this was not so good, so I did

(define (neighbor-count a)
   (let* ((big-a      (array-engorge a))
          (domain     (array-domain a))
          (translates (map (lambda (translation)
                             (array-extract (array-translate big-a
translation) domain))
                           '(#(1 0) #(0 1) #(-1 0) #(0 -1)
                             #(1 1) #(1 -1) #(-1 1) #(-1 -1)))))
     (array-map
      (lambda (a b) (+ a b))
      (apply array-map (lambda (a b c d) (+ a b c d)) (take translates 4))
      (apply array-map (lambda (a b c d) (+ a b c d)) (drop translates
4)))))

and this was reasonable performance, I think. (This could be considered
a Gambit quality-of-implementation issue.)

So with

(define (game-rules a neighbor-count)
   ;; a is a single cell
   (if (= a 1)
       (if (or (= neighbor-count 2)
               (= neighbor-count 3))
           1 0)
       ;; (= a 0)
       (if (= neighbor-count 3)
           1 0)))

(define (advance a)
   ;; result array has same storage class
   ;; as input array
   (array-copy
    (array-map game-rules a (neighbor-count a))
    (array-storage-class a)))

I got with the generalized expanded array

(compile-file "life")

 > "/home/lucier/lang/scheme/srfi-231/srfi-231-temp/life.o13"
 > (load "life")

"generalized array-engorge"
"/home/lucier/lang/scheme/srfi-231/srfi-231-temp/life.o13"
 > (define initial (array-copy (make-array (make-interval '#(1000 1000))
(lambda args (random-integer 2))) u1-storage-class))
 > (define a (time (advance initial)))

(time (advance initial))
     0.362144 secs real time
     0.360450 secs cpu time (0.360441 user, 0.000009 system)
     no collections
     140552 bytes allocated
     30 minor faults
     no major faults
 > (define initial (array-copy (make-array (make-interval '#(1000 1000))
(lambda args (random-integer 2))) u8-storage-class))
 > (define a (time (advance initial)))

(time (advance initial))
     0.334215 secs real time
     0.334216 secs cpu time (0.334216 user, 0.000000 system)
     no collections
     1015472 bytes allocated
     244 minor faults
     no major faults

and with the specialized expanded array:

 > (compile-file "life")

"/home/lucier/lang/scheme/srfi-231/srfi-231-temp/life.o14"
 > (load "life")

"specialized array-engorge"
"/home/lucier/lang/scheme/srfi-231/srfi-231-temp/life.o14"
 > (define initial (array-copy (make-array (make-interval '#(1000 1000))
(lambda args (random-integer 2))) u1-storage-class))
 > (define a (time (advance initial)))

(time (advance initial))
     0.195044 secs real time
     0.194162 secs cpu time (0.194162 user, 0.000000 system)
     no collections
     280904 bytes allocated
     62 minor faults
     no major faults
 > (define initial (array-copy (make-array (make-interval '#(1000 1000))
(lambda args (random-integer 2))) u8-storage-class))
 > (define a (time (advance initial)))

(time (advance initial))
     0.154782 secs real time
     0.154785 secs cpu time (0.154785 user, 0.000000 system)
     no collections
     2033544 bytes allocated
     471 minor faults
     no major faults

These allocation numbers start to make sense.

Brad