aLGoCI/lattice.scm

#!/usr/bin/guile
!#

;    A Lattice Game of Cosmic Insignificance:
;    A small game about mathematical lattices and tribes.

;    Copyright (C) 2019 <houkime at protonmail.com>

;    This program is free software: you can redistribute it and/or modify
;    it under the terms of the GNU General Public License as published by
;    the Free Software Foundation, either version 3 of the License, or
;    (at your option) any later version.
;
;    This program is distributed in the hope that it will be useful,
;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;    GNU General Public License for more details.

;    You should have received a copy of the GNU General Public License
;    along with this program.  If not, see <https://www.gnu.org/licenses/>.

(use-modules (chickadee)
             (chickadee math vector)
	     (chickadee math rect)
             (chickadee render font)
	     (chickadee render sprite)
	     (chickadee render texture)
	     (oop goops)
	     (oop goops describe)
	     (srfi srfi-1)
	     (ice-9 format)
	     )

(define-class <node> ()
	      (name #:init-keyword #:name)
	      (more #:init-keyword #:more #:init-value '())
	      (less #:init-keyword #:less #:init-value '())
	      (init_type #:init-keyword #:init_type #:init-value "mammalian"); 
	      (type_changed #:init-keyword #:type_changed #:init-value #f))

(define list_interrow_dist 15)

(define action "join"); can be join or meet
(define target #f) ; these 2 are specified at load time
(define current #f)

(define imbalance 0)
(define turns-taken 0)

(define (bump_turns)
  (set! turns-taken (+ turns-taken 1))
  (update-turns-label))

(define (update-turns-label)
  (slot-set! turns-taken-label 'str (simple-format #f "~A Turns Taken" turns-taken)))

(define (typestat type)
  (fold + 0 (map (lambda (node)
		 (if (eqv? (get-node-type node) type) 1 0)) lattice)))


(define (calculate-imbalance)
  (set! imbalance (- (typestat "mammalian") (typestat "bird")))
  (slot-set! imbalance-label 'str (simple-format #f "Cosmic imbalance is ~A" imbalance))
  (if (eqv? imbalance 0) (display-term "Balance is restored. you sorta won")))


(define-class <tree_node> ()
	      (position #:init-keyword #:position #:init-value #v(0 0))
	      (visible #:init-value #t #:init-keyword #:visible)
	      (parent #:init-value #f #:init-keyword #:parent)
	      (children #:init-value '())
	      )

(define-class <clickable> (<tree_node>)
	      (rect #:init-keyword #:rect #:init-value (make-rect 0 0 100 15))
	      (click-enabled #:init-keyword #:click-enabled #:init-value #t)
	      (on_click #:init-keyword #:on_click #:init-value (lambda (self)
								 (display "click!")))
	      )


(define-class <button> (<clickable>) 
	      (str #:init-keyword #:str))

(define-class <terminal_widget> (<tree_node>) 
	      (item_height #:init-value 15)
	      (max_lines #:init-value 20)
	      (width #:init-value 300)
	      (lines #:init-value '())
	      )

(define-method (add-entry (term <terminal_widget>) str)
	       (add-child term (make <label> #:str str))
	       (if (> (length (slot-ref term 'children)) (slot-ref term 'max_lines))
		   (begin
		     (display "unparenting excessive stuff")
		     (unparent (list-ref (slot-ref term 'children) 0))
		     ))


	       )

(define-method (clear-children (node <tree_node>))
	       (let ((children-list (slot-ref node 'children)))
		 (slot-set! node 'children '())
		 (for-each unparent children-list)))

(define (display-term str)
  (add-entry terminal str))

(define-class <label> (<tree_node>) 
	      (str #:init-value "label" #:init-keyword #:str))

(define-class <list_widget> (<tree_node>) 
	      (item_height #:init-value 15)
	      (on_selected #:init-keyword #:on_selected #:init-value (lambda (self key)
								       (display "list clicked"))))

(define-class <list_entry> (<button>)
	      (key #:init-keyword #:key)	      
	      (on_click #:init-keyword #:on_click 
			#:init-value (lambda (self)
				       ((slot-ref (slot-ref self 'parent) 'on_selected) 
					(slot-ref self 'parent) (slot-ref self 'key))))
	      )

(define-method (activate (lw <list_widget>))
	       (for-each  (lambda (x) 
			    (slot-set! x 'visible #t)
			    (slot-set! x 'click-enabled #t))
			  (slot-ref lw 'children))) 

(define-method (inactivate (lw <list_widget>))
	       (for-each  (lambda (x) 
			    (slot-set! x 'visible #f)
			    (slot-set! x 'click-enabled #f))
			  (slot-ref lw 'children))) 


(define-method (toggle_active (lw <list_widget>))
	       (for-each  (lambda (x) 
			    (slot-set! x 'visible (not (slot-ref x 'visible)))
			    (slot-set! x 'click-enabled (not (slot-ref x 'click-enabled))))
			  (slot-ref lw 'children))) 


(define-class <folding_list> (<button>)
	      lw
	      (on_click #:init-keyword #:on_click 
			#:init-value (lambda (self)
				       (for-each  (lambda (x) (toggle_active x))
						  (slot-ref self 'children) ))))

(define-method (initialize (instance <folding_list>) . initargs)
	       (next-method)
	       (let ((lw (make <list_widget> #:position #v(0 15))))
		 (slot-set! instance 'lw lw)
		 (add-child instance lw))
	       (display "initializing a folding list mutafuka\n")
	       )

(define-method (tree-node-self-draw (button <button>))
	       (let ((pos (get_global_position button)))
		 (draw-nine-patch list_background_patch (rect-move-vec2 
							  (make-rect 0 0 100 list_interrow_dist)
							  pos)
							  #:margin 6)
		 (draw-text (slot-ref button 'str) pos)))

(define-method (tree-node-self-draw (label <label>))
	       (let ((pos (get_global_position label)))
		 (draw-text (slot-ref label 'str) pos)))

(define-method (draw-tree (node <tree_node>))
	       (if (slot-ref node 'visible)
		   (begin 
		     (tree-node-self-draw node)
		     (for-each draw-tree (slot-ref node 'children))
		     )))

(define-method (add-child (node <tree_node>) (child <tree_node>))
	       ;(describe child)
	       (slot-set! node 'children (append (slot-ref node 'children) (list child)))
	       ;(display (slot-ref node 'children))
	       (slot-set! child 'parent node))
 
(define-method (unparent (child <tree_node>))
	       (let ((parent (slot-ref child 'parent)))
		 (slot-set! parent 'children (delq child (slot-ref parent 'children))))
	       (slot-set! child 'parent #f))




(define-method (tree-node-self-draw (node <tree_node>)))

(define scene (make <tree_node>)); the scene root

(define list_background_patch #f)

(define-method (tree-node-self-draw (lst <list_widget>))
	       ;(display "drawing list\n")
	       (let ((offset 0))
	         (for-each (lambda (child)			   
			     (slot-set! child 'position 
					#v(0 offset))
			     (set! offset (+ offset list_interrow_dist))) 
			   (slot-ref lst 'children))))

(define-method (tree-node-self-draw (term <terminal_widget>))
	       (let* ((offset 0)
		     (pos (get_global_position term))
		     (overall_height (* list_interrow_dist (slot-ref term 'max_lines)))
		     (term_bg_rect (rect-move-vec2 
				     (make-rect 0 0 (slot-ref term 'width) overall_height)
				     (vec2+ pos 
					    #v(0 (- (- overall_height list_interrow_dist))))))	
		     )
		 (draw-nine-patch list_background_patch term_bg_rect #:margin 6)
		 (for-each (lambda (child)			   
			     (slot-set! child 'position 
					#v(0 offset))
			     (set! offset (- offset list_interrow_dist))) 
			   (slot-ref term 'children))
		 ))


(define-method (clickable-click (clickable <clickable>) x y)
	       ;(display (in_bound? clickable x y))
	       ;(newline)
	       (if (and (in_bound? clickable x y) (slot-ref clickable 'click-enabled)) 
		   ((slot-ref clickable 'on_click) clickable)))

(define-method (clickable-click clickable x y))

(define-method (in_bound? (clickable <clickable>) x y)
	       ;(display (list "clickable" clickable x y))
	       ;(newline)
	       (let ((global_rect (rect-move-vec2 (slot-ref clickable 'rect) 
						  (get_global_position clickable))))
		 ;(display global_rect)
		 ;(newline)
		 (rect-contains? global_rect x y)))

(define-method (get_global_position (node <tree_node>))
	       (if (slot-ref node 'parent)
		   (vec2+ (slot-ref node 'position) (get_global_position 
						      (slot-ref node 'parent)))
		   (slot-ref node 'position)))

(define-method (add-entry (lst <folding_list>) str key)
	       (add-child (slot-ref lst 'lw) (make <list_entry> #:str str #:key key 
				  #:visible #f #:click-enabled #f)))

(define-method (clear-entries (lst <folding_list>))
	       (for-each unparent (slot-ref (slot-ref lst 'lw) 'children)))

#!

(define lattice
  (list
    (make <node> #:name "Raven" #:init_type "divine")
    (make <node> #:name "Coyote" #:init_type "divine" #:more '("Falcon" "Jay" "Gnu"))
    (make <node> #:name "Bear" #:init_type "mammalian" #:more '("Raven"))
    (make <node> #:name "Eagle" #:init_type "bird" #:more '("Bear"))
    (make <node> #:name "Gnu" #:init_type "mammalian" #:more '("Eagle"))
    (make <node> #:name "Jay" #:init_type "bird" #:more '("Raven"))
    (make <node> #:name "Tit" #:init_type "bird" #:more '("Bear"))
    (make <node> #:name "Falcon" #:init_type "bird" #:more '("Tit"))
    ))

!#

(define lattice
  (list
    (make <node> #:name "Raven" #:init_type "divine")
    (make <node> #:name "Coyote" #:init_type "divine" #:more '("Tit" "Gnu"))
    (make <node> #:name "Gnu" #:init_type "mammalian" #:more '("Dodo" "Jay"))
    (make <node> #:name "Jay" #:init_type "bird" #:more '("Tit"))
    (make <node> #:name "Dodo" #:init_type "bird" #:more '("Cuckoo" "Falcon" "Owl"))
    (make <node> #:name "Falcon" #:init_type "bird" #:more '("Beaver"))
    (make <node> #:name "Cuckoo" #:init_type "bird" #:more '("Bear"))
    (make <node> #:name "Beaver" #:init_type "mammalian" #:more '("Raven"))
    (make <node> #:name "Bear" #:init_type "mammalian" #:more '("Eagle"))
    (make <node> #:name "Owl" #:init_type "bird" #:more '("Eagle"))
    (make <node> #:name "Tit" #:init_type "bird" #:more '("Plover" "Heron"))
    (make <node> #:name "Plover" #:init_type "bird" #:more '("Eagle"))
    (make <node> #:name "Eagle" #:init_type "bird" #:more '("Raven"))
    (make <node> #:name "Heron" #:init_type "bird" #:more '("Raven"))
    ))


(define (add-less lat)
  (for-each (lambda (node) 
	      (for-each (lambda (more-node-name)
			  (let ((target-node (get-node more-node-name)))
			    (slot-set! target-node 'less (append
							   (list (slot-ref node 'name))
							   (slot-ref target-node 'less)))))
			(slot-ref node 'more)))
	      lat))



(define (get-node name)
  (let ((lst (filter (lambda (node) (eqv? (slot-ref node 'name) name)) lattice)))
    (list-ref lst 0)))


(define (get-rel-tree node symbol)
	       (append (list node) 
		       (delete-duplicates 
			 (concatenate (map (lambda (n)
					     (get-rel-tree n symbol)) 
					   (map get-node (slot-ref node symbol)))))))


(define-method (get-name (node <node>))
	       (slot-ref node 'name))

(define (find-join lst)
  (find-rel lst 'more #f))

(define (find-meet lst)
  (find-rel lst 'less #f))

(define (anti-rel symbol)
  (if (eq? 'more symbol) 'less 'more))

(define (find-rel lst symbol restricted)
  (display (list "trying to rel with symbol" symbol))
  (newline)
  (display (map get-name lst))
  (newline)

  (let ((intersec (apply lset-intersection 
			 (append (list eqv?)
				 (map (lambda (n) (get-rel-tree n symbol)) 
				      lst)))))
    (display "intersection\n")
    (display (map get-name intersec))
    (if restricted 
	(list-ref (lset-intersection eqv? intersec lst) 0)
	(find-rel intersec (anti-rel symbol) #t))
    )
  )


(define-method (get-node-type (node <node>))
	       (if (not (slot-ref node 'type_changed)); "divine" never changes type
		   (slot-ref node 'init_type)
		   (if (eqv? (slot-ref node 'init_type) "mammalian") "bird" "mammalian")))

(define (list-valid-nodes current)
  (let* ((current (get-node current))
	 (faction (get-node-type current)))
    (if (not (string=? (get-node-type current) "divine"))
	(if (eqv? action "join")
	    (filter (lambda (node)
		      (and 
			(not (eqv? (get-node-type node) faction))
			(not (eqv? (get-node-type node) "divine"))))
		    lattice)
	    (filter (lambda (node)
		      (and 
			(eqv? (get-node-type node) faction)
			(not (eqv? (get-node-type node) "divine"))
			(not (eqv? node current))))
		    lattice))
	(filter (lambda (node) (not (eqv? (get-node-type node) "divine"))) lattice)
	)))


(define action_list 
  (begin
    (let ((lst (make <folding_list> #:str "action_list" #:position #v(0 0))))
      (add-entry lst "join" "join")
      (add-entry lst "meet" "meet")
      (slot-set! (slot-ref lst 'lw) 
		 'on_selected 
		 (lambda (self key)
		   (display (list "selected" key))
		   (set! action key)
		   (slot-set! (slot-ref self 'parent) 'str key)
		   (inactivate self)
		   (fill_with_choices node_list)
		   ))
      
      (slot-set! lst 'str action)
      lst
      )))

(define node_list 
  (make <folding_list> #:str "node_list" #:position #v(100 0)))

(define (fill_with_choices node_list)
  (clear-entries node_list)
  (let ((nodes (list-valid-nodes current)))
    (for-each (lambda (node) 
		(add-entry node_list 
			   (get-full-name (slot-ref node 'name)) 
			   (slot-ref node 'name))) 
	      nodes)
    (set! target (slot-ref (list-ref nodes 0) 'name))
    (slot-set! node_list 'str (get-full-name target))))

(define (get-full-name node-name)
  (let ((node (get-node node-name)))
    (if (slot-ref node 'type_changed); divine never changes type
	(if (eqv? (get-node-type node) "mammalian"); new type, not old
	    (string-append node-name "-With-Tits")
	    (string-append "Feathered " node-name))
	node-name)))


(define (take_action self)
  (display "taking a decisive action\n")
  (let ((target-node (get-node target))
	(current-node (get-node current)))
    (if (eqv? action "join")
	(begin
	  (if (not (eqv? (get-node-type current-node) "divine"))
	      (begin 
		(slot-set! current-node 'type_changed 
			   (not (slot-ref current-node 'type_changed)))
		(display-term (simple-format #f "~A helps you overcome your past" (get-full-name target)))
		(display-term "You transform.")
		(display-term (simple-format #f "you are now known as ~A" (get-full-name current))))
	      (begin
		(display-term (simple-format #f "You come to ~A in his dreams" (get-full-name target)))))
	      
	  (calculate-imbalance)
	  (set! current (slot-ref (find-join (map get-node (list current target))) 'name))
	  )
	(begin
	  (if (not (eqv? (get-node-type current-node) "divine"))
	      (begin 
		(display-term (simple-format #f "Meeting with The ~A" (get-full-name target)))
		(display-term "You eat pretzels and discuss clanly matters"))
	      (begin
		(display-term (simple-format #f "You come to ~A in his dreams" (get-full-name target)))))
	  (set! current (slot-ref (find-meet (map get-node (list current target))) 'name)) 
	  )))
  (bump_turns)
  (fill_with_choices node_list)
  (morning-message)
  )

(define (morning-message)
  (display-term "* * *")
  (display-term "Sun rises and you wake up.")
  (display-term (simple-format #f "You are The ~A." (get-full-name current)))
	  (if (eqv? (get-node-type (get-node current)) "divine")
	      (display-term "... a supposedly divine being."))
	  )


(define terminal 
  (make <terminal_widget> #:position #v(0 400)))

(define imbalance-label
  (make <label> #:position #v(0 450)))

(define turns-taken-label
  (make <label> #:position #v(0 435)))

(define (reset-lattice)
  (for-each (lambda (n)
	      (slot-set! n 'type_changed #f))
	    lattice))

(define (reset-scene)
  (set! scene (make <tree_node>)))


(define (load)
  (set! current "Bear")
  (add-less lattice)
  (add-child scene imbalance-label)
  (add-child scene turns-taken-label)
  (calculate-imbalance)
  (update-turns-label)
  (display (list "imbalance is " imbalance))
  ;(for-each describe lattice)
  ;(display (map (lambda (node) (list (slot-ref node 'name) (get-node-type node))) lattice))
  (set! list_background_patch (load-image "images/dialog-box.png"))
  
  (add-child scene terminal)
  (morning-message)
  (display-term "You brush your beary teeth.")
  (display-term "Annoyingly, you feel like cosmic balance is off")
  (display-term "However that might be just your stomache.")

  (add-child scene action_list)

  (fill_with_choices node_list) 
  (add-child scene node_list)
  (slot-set! (slot-ref node_list 'lw) 
	     'on_selected 
	     (lambda (self key)
	       (display (list "selected" key))
	       (set! target key)
	       (slot-set! (slot-ref self 'parent) 'str (get-full-name key))
	       (inactivate self)))



  (add-child scene (make <button> 
			 #:str "make turn" 
			 #:position #v(200 0)
			 #:on_click take_action))

  (add-child scene (make <button> 
			 #:str "reset" 
			 #:position #v(200 465)
			 #:on_click reset))

  (describe scene))

(define (reset self)
  (display "reset called\n")
  (reset-lattice)
  (display "lattice cleared\n")
  (reset-scene)
  (clear-children terminal)
  (display "scene cleared\n")
  (load)
  (display "scene reloaded\n")
  (set! turns-taken 0)
  (update-turns-label)
  )

(define (draw alpha)
  (draw-tree scene))

(define-method (click-rec (node <tree_node>) x y)
	       ;(display (list node x y))
	       ;(newline)
	       (clickable-click node x y)
	       (for-each (lambda (child) (click-rec child x y)) (slot-ref node 'children)))

(define (mouse-release button x y)
  (click-rec scene x y)
  ;(newline)
  )


(run-game #:draw draw #:load load #:mouse-release mouse-release 
	  #:window-width 300 #:window-title "A Lattice Game of Cosmic Insignificance")