Update for SLGJ 2024

5 files changed, 329 insertions, 68 deletions

diff --git a/scripts/gol.scm b/scripts/gol.scm
index 7e10d2d..e0732a6 100644
--- a/scripts/gol.scm
+++ b/scripts/gol.scm
@@ -3,12 +3,6 @@
 (define neighbors
   '((-1 . -1) (0 . -1) (1 . -1) (-1 . 0) (1 . 0) (-1 . 1) (0 . 1) (1 . 1)))
 
-(set! (current-cells '(1 . 1)) #t)
-(set! (current-cells '(2 . 1)) #t)
-(set! (current-cells '(3 . 1)) #t)
-(set! (current-cells '(3 . 0)) #t)
-(set! (current-cells '(2 . -1)) #t)
-
 (define sum-cells
   (lambda (c1 c2)
     (cons (+ (car c1) (car c2)) (+ (cdr c1) (cdr c2)))))
@@ -37,8 +31,10 @@
 (define list-neighbors
   (lambda (c)
     (map (lambda (n)
-           (sum-cells c n))
-         neighbors)))
+	   (sum-cells c n)
+	   )
+	 neighbors)
+    ))
 
 (define sum-live-cells
   (lambda (lat n)
@@ -76,3 +72,26 @@
       )
     )
   )
+
+(define (clear-cells)
+  (set! current-cells (make-hash-table))
+  )
+
+(define (toggle-cell c)
+  (if (current-cells c)
+      (set! (current-cells c) #f)
+      (set! (current-cells c) #t)
+      )
+  )
+
+(define (set-cells-array arr)
+  (map (lambda (c)
+	 (set! (current-cells c) #t)
+	 )
+       arr
+       )
+  )
+
+(define (get-cells-list)
+  (hash-table-keys current-cells)
+  )
diff --git a/scripts/main.scm b/scripts/main.scm
index 5dcbe10..9db17fc 100644
--- a/scripts/main.scm
+++ b/scripts/main.scm
@@ -3,53 +3,297 @@
 (load "./scripts/prompt.scm")
 (load "./scripts/gol.scm")
 
-(define camera-offset (make-point))
-(define space-pressed #f)
+(define current-stage-number 0)
+(define current-generation 0)
+(define current-pressed-key #f)
+(define starting-cells (list))
+(define trigger-level-reload #t)
+(define overlay-fade-time 0.0)
+(define is-advancing #f)
 
-(define (update)
-  (prompt-update)
 
-  (cond ((not prompt-active)
-	 (if (rl-is-key-down KEY_DOWN)
-	     (set! (point-y camera-offset) (+ (point-y camera-offset) 2))
-	     )
-	 
-	 (if (rl-is-key-down KEY_UP)
-	     (set! (point-y camera-offset) (+ (point-y camera-offset) -2))
-	     )
+(define stages (list (list '(1 . 0)
+			   '(1 . 1)
+			   '(0 . 0)
+			   '(0 . 1))
+		     (list '(0 . -1)
+			   '(1 . 0)
+			   '(0 . 1)
+			   '(-1 . 0))
+		     (list '(0 . 0)
+			   '(0 . 1)
+			   '(0 . 2))
+		     (list '(0 . 0)
+			   '(-1 . 0)
+			   '(0 . -1))
+		     (list '(1 . 0)
+			   '(0 . 1))
+		     (list '(2 . 0)
+			   '(1 . 0)
+			   '(1 . 1)
+			   '(0 . 1)
+			   '(0 . 2))
+		     (list '(-1 . -1)
+			   '(0 . -1)
+			   '(1 . 0)
+			   '(0 . 1)
+			   '(-1 . 1)
+			   '(-2 . 0))
+		     (list '(-1 . -1)
+			   '(0 . -1)
+			   '(1 . -1)
+			   '(-1 . 0)
+			   '(1 . 0)
+			   '(-1 . 1)
+			   '(0 . 1)
+			   '(1 . 1))
+		     (list '(0 . -1)
+			   '(0 . 0)
+			   '(0 . 1)
+			   '(1 . -1)
+			   '(1 . 0)
+			   '(1 . 1)
+			   '(2 . 0))
+		     ))
 
-	 (if (rl-is-key-down KEY_LEFT)
-	     (set! (point-x camera-offset) (+ (point-x camera-offset) -2))
+(define (update-generation)
+  (clear-cells)
+  (set-cells-array starting-cells)
+
+  (let loop ((times 0))
+    (if (< times current-generation)
+	(begin (run-step)
+	       (loop (+ times 1)))
+	)
+    )
+  )
+
+(define (is-solution? l1)
+  (define trigger #t)
+  (for-each (lambda (c)
+	      (if (not (hash-table-ref current-cells c))
+		  (begin (set! trigger #f)))
+	      )
+	    (stages current-stage-number))
+  (and trigger (eq? (length (stages current-stage-number)) (length (hash-table-keys current-cells))))
+  )
+
+(define (update-game)
+  
+  (set! current-pressed-key (rl-get-key-pressed))
+  
+  (prompt-update)
+
+  (if trigger-level-reload
+      (begin (set! starting-cells (list))
+	     (clear-cells)
+	     (set-cells-array starting-cells)
+	     (set! trigger-level-reload #f)))
+  
+  (cond ((and (not prompt-active) (not is-advancing))
+	 (if (eq? current-pressed-key KEY_LEFT)
+	     (cond ((> current-generation 0)
+		    (set! current-generation (- current-generation 1))
+		    (update-generation)))
 	     )
 	 
-	 (if (rl-is-key-down KEY_RIGHT)
-	     (set! (point-x camera-offset) (+ (point-x camera-offset) 2))
+	 (if (eq? current-pressed-key KEY_RIGHT)
+	     (cond ((< current-generation 1)
+		    (set! current-generation (+ current-generation 1))
+		    (update-generation)))
 	     )
 	 
-	 (cond ((and (rl-is-key-down KEY_SPACE) (not space-pressed))
-		(set! space-pressed #t)
-		(run-step))
-	       )
-	 
-	 (if (not (rl-is-key-down KEY_SPACE))
-	     (set! space-pressed #f)
-	     )
 	 ))
+
+  (if (and (eq? current-generation 1) (not is-advancing))
+      (if (is-solution? (stages current-stage-number))
+	  (begin (set! is-advancing #t)
+		 (set! overlay-fade-time 0.0))
+	  )
+      )
+
+  (if (and (rl-is-mouse-button-pressed) (eq? current-generation 0))
+      (let ((mouse-pos (rl-get-mouse-position)))
+	(define tile-x (floor ( / (- (mouse-pos 0) 275) 50)))
+	(define tile-y (floor ( / (- (mouse-pos 1) 200) 50)))
+	(if (and (>= tile-x -1)
+		 (<= tile-x 1)
+		 (>= tile-y -1)
+		 (<= tile-y 1))
+	    (begin (toggle-cell `(,tile-x . ,tile-y))
+		   (set! starting-cells (get-cells-list))))
+	))
+
+  (if is-advancing
+      (set! overlay-fade-time (+ overlay-fade-time (rl-get-frame-time)))
+      (set! overlay-fade-time (- overlay-fade-time (rl-get-frame-time)))
+      )
+
+  (if (> overlay-fade-time 1.0)
+      (begin (set! is-advancing #f)
+	     (clear-cells)
+	     (set! starting-cells (list))
+	     (set! current-generation 0)
+	     (set! current-stage-number (+ current-stage-number 1))
+	     )
+      )
   )
 
-(define (draw)
+(define (update-end)
+  (if is-advancing
+      (set! overlay-fade-time (+ overlay-fade-time (rl-get-frame-time)))
+      (set! overlay-fade-time (- overlay-fade-time (rl-get-frame-time)))
+      )
+  )
+
+(define (update)
+  (if (>= current-stage-number (length stages))
+      (update-end)
+      (update-game)
+      )
+  )
+
+(define (draw-game)
+  (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 255))
+  
   (prompt-draw)
+  
+  (rl-draw-text (string-append "Level " (number->string current-stage-number)) 75 15 20 (make-color 0 0 0 255))
+
+  (draw-cells)
+
+  (draw-grid)
+
+  (draw-generation)
+  
+  (define lerped-alpha (* 255.0 overlay-fade-time) )
+  (if (< lerped-alpha 0.0)
+      (set! lerped-alpha 0.0))
+
+  (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 (floor lerped-alpha)))
+  )
+
+(define (draw-end)
+  (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 255))
+  
+  (rl-draw-text "The end! Thank you for playing :)"  38 200 30 (make-color 0 0 0 255))
+
+  (rl-draw-text "Made with Raylib + S7 Scheme"  146 340 20 (make-color 0 0 0 255))
+  
+  (define lerped-alpha (* 255.0 overlay-fade-time) )
+  (if (< lerped-alpha 0.0)
+      (set! lerped-alpha 0.0))
+
+  (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 (floor lerped-alpha)))
+  )
+
+(define (draw-generation)
+  
+  (let loop ((times 0))
+    (if (< times 2)
+	(begin
+	  (rl-draw-rectangle (+ 75 (* times 40))
+			     410
+			     30
+			     30
+			     (make-color 190 190 190 255))
+	  (if (eq? times current-generation)
+	      (rl-draw-rectangle (+ 80 (* times 40))
+				 415
+				 20
+				 20
+				 (make-color 0 0 0 255)))
+	  
+	  (loop (+ times 1))
+	  )))
+
+  )
+
+(define (draw)
+  (if (>= current-stage-number (length stages))
+      (draw-end)
+      (draw-game)
+      )
+  )
+
 
+(define (draw-grid)
+  (define cell-width 50)
+  (define cell-height 50)
+  
+  (let loop ((times 10))
+    (if (> times 0)
+	(begin (rl-draw-line (+ (* times cell-width) (* cell-width 0.5))
+			     50
+			     (+ (* times cell-width) (* cell-width 0.5))
+			     400
+			     (make-color 200 200 200 255))
+	       (loop (- times 1)))
+	)
+    )
+
+  (let loop ((times 8))
+    (if (> times 0)
+	(begin (rl-draw-line 75
+			     (* times cell-height)
+			     525
+			     (* times cell-height)
+			     (make-color 200 200 200 255))
+	       (loop (- times 1)))
+	)
+    )
+
+  (let loop ((times 4))
+    (if (> times 0)
+	(begin (rl-draw-line (+ (* times cell-width) 175)
+			     150
+			     (+ (* times cell-width) 175)
+			     300
+			     (make-color 0 0 0 255))
+	       (loop (- times 1)))
+	)
+    )
+
+  (let loop ((times 4))
+    (if (> times 0)
+	(begin (rl-draw-line 225
+			     (+ (* times cell-height) 100)
+			     375
+			     (+ (* times cell-height) 100)
+			     (make-color 0 0 0 255))
+	       (loop (- times 1)))
+	)
+    )
+  )
+
+(define (draw-cells)
+  (define cell-width 50)
+  (define cell-height 50)
+  (define cell-color (if (eq? current-generation 0)
+			 (make-color 190 100 255 255)
+			 (make-color 255 190 100 255)))
+
+  
   (for-each (lambda (cell)
 	      (rl-draw-rectangle
-	       (+ (* (car cell) 30) (point-x camera-offset))
-	       (+ (* (cdr cell) 30) (point-y camera-offset))
-	       30
-	       30
-	       (make-color 190 100 255))
+	       (+ (* (car cell) cell-width) (- 300 (* cell-width 0.5)) )
+	       (+ (* (cdr cell) cell-height) (- 225 (* cell-height 0.5)) )
+	       cell-width
+	       cell-height
+	       cell-color)
 	      
 	      ) (hash-table-keys current-cells))
-  
-  )
 
 
+  (for-each (lambda (cell)
+	      (rl-draw-rectangle
+	       (+ (* (car cell) 50) 290 )
+	       (+ (* (cdr cell) 50) 215 )
+	       20
+	       20
+	       (make-color 255 190 100 255))
+	      
+	      ) (stages current-stage-number))
+
+  
+  )
diff --git a/scripts/prompt.scm b/scripts/prompt.scm
index 3440b28..32e7606 100644
--- a/scripts/prompt.scm
+++ b/scripts/prompt.scm
@@ -3,35 +3,32 @@
 (define prompt-text "")
 
 (define (prompt-update)
-  (let ((key-pressed (rl-get-key-pressed)))
-    
-    
-    (if (eq? key-pressed KEY_F1)
-	(set! prompt-active (not prompt-active))
-	)
-    
-    (if prompt-active
-	(begin
-	  (let ((key (rl-get-char-pressed)))
-	    (cond ((and (>= key 32) (<= key 125))
-		   (set! prompt-text
-			 (string-append prompt-text (string (integer->char key)))))
-		  ))
-	  
-	  (if (rl-is-key-down KEY_ENTER)
-	      (begin
-		(eval-string prompt-text)
-		(set! prompt-text "")
+  (if (eq? current-pressed-key KEY_F1)
+      (set! prompt-active (not prompt-active))
+      )
+  
+  (if prompt-active
+      (begin
+	(let ((key (rl-get-char-pressed)))
+	  (cond ((and (>= key 32) (<= key 125))
+		 (set! prompt-text
+		       (string-append prompt-text (string (integer->char key)))))
 		))
-	  
-	  (if (eq? key-pressed KEY_BACKSPACE)
-	      (let ((n (string-length prompt-text)))
-		(cond ((>= n 1)
-		       (set! prompt-text (substring prompt-text 0 (- n 1))))
-		      )))
-	  
-	  ))
-    )
+	
+	(if (rl-is-key-down KEY_ENTER)
+	    (begin
+	      (eval-string prompt-text)
+	      (set! prompt-text "")
+	      ))
+	
+	(if (eq? current-pressed-key KEY_BACKSPACE)
+	    (let ((n (string-length prompt-text)))
+	      (cond ((>= n 1)
+		     (set! prompt-text (substring prompt-text 0 (- n 1))))
+		    )))
+	
+	))
+  
   )
 
 (define (prompt-draw)
diff --git a/scripts/stage.scm b/scripts/stage.scm
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/scripts/stage.scm
diff --git a/scripts/structs.scm b/scripts/structs.scm
index e6be071..c3fa6ea 100644
--- a/scripts/structs.scm
+++ b/scripts/structs.scm
@@ -77,3 +77,4 @@
 
 (defstruct rect (x 0.0) (y 0.0) (width 0.0) (height 0.0))
 (defstruct point (x 0.0) (y 0.0))
+(defstruct stage (width 0) (height 0) (generations 0) (final-state #f))