groworld/plant-eyes/plant-eyes-logic.scm

#lang scheme/base
(require fluxus-016/drflux)
(require scheme/class)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; p l a n t   e y e s   
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

; notes:
;
; * keeping with a render/logic separation, although this is quite different to 
;   the hexagon game. the main advantage is that the logic can be ticked at a 
;   lower frequency - or even different parts at different rates, whereas the 
;   renderer side needs ticking every frame
;
; * need to try to keep all the intensive every thing vs every thing checking 
;   in the logic side, where it can be done over many frames (i'm thinking the
;   lags involved with things like nutrients getting absorbed may not matter 
;   too much in this game)
;
; * using a message passing system to formalise the passing of information on 
;   the logic side. this makes it possible to have objects sending messages
;   at any point, and have them collected up and dispached in the renderer side
;
; * line segments are computed in the logic side, and can be represented any
;   way by the renderer - maybe the players plant will be geometry and everyone
;   elses will be ribbons (stoopid LOD)

(define branch-probability 10) ; as in, one in 10
(define branch-width-reduction 0.95)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a message for sending betwixt logic and render side
(define message%
  (class object%
    (init-field
     (name 'none) ; a symbol denoting the type of the message 
     (data '()))  ; should be an assoc list map of name to values, eg:
                  ; '((name "archibold") (age 53))
                  ; shouldn't put logic objects in here - 'raw' data only
    
    (define/public (get-data arg-name)
      (cadr (assoc arg-name data)))
    
    (define/public (print)
      (printf "msg: ~a ~a~n" name data))
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; the base class logic object - all logic side objects can 
; send messages to the render side at any time by calling add-message
; this takes care of the propagation of information. (not just oo fetish, I hope)
(define game-logic-object%
  (class object%
    (field
     (messages '())
     (children '()))
    
    (define/public (send-message name data)
      (set! messages (cons (make-object message% name data) messages)))
        
    ; convert a list of lists in to just a single list - needed to convert
    ; the update lists into one big list of messages
    (define (flatten l)
      (cond
        ((null? l) '())
        ((list? (car l)) (append (flatten (car l)) (flatten (cdr l))))
        (else (cons (car l) (flatten (cdr l))))))

    (define/pubment (update) ; need to augement this if we have child logic objects, 
      (let ((m messages))    ; and call update on them too.
        (set! messages '())        
         (append
          (flatten (inner (void) update)) ; the augmented method gets called here
          m)))
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a twig, which can contain other twigs things.
; (roots and shoots are both twigs)
(define twig-logic%
  (class game-logic-object%
    (init-field
     (id #f)               ; our id (for matching up with the renderer geometry)
     (plant #f)            ; the plant we belong to
     (type 'root)          ; or 'shoot
     (dir (vector 0 1 0))  ; the general direction we are pointing in
     (width 1))            ; the width of this root
    
    (field
     (points '())     ; the 3d points for this twig
     (twigs '())      ; children are stored with the point number they are connected to.
     (ornaments '())) ; the things attached to this twig, an assoc list with point index

    (inherit send-message)
    
    (define/public (get-id)
      id)
    
    (define/public (set-id! s)
      (set! id s))
    
    (define/public (get-type)
      type)
    
    (define/public (get-dir)
      dir)
    
    (define/public (get-point point-index)
      (list-ref points point-index))
    
    (define/public (grow)
      (let ((new-point (vector 0 0 0))) ; todo: grow along dir
        (set! points (append points (list new-point))) ; 
        (send-message 'twig-grow (list 
                                  (list 'plant-id (send plant get-id))
                                  (list 'twig-id id)
                                  (list 'point new-point))))
      (when (zero? (random branch-probability))
        (add-twig (- (length twigs) 1) 
                  (make-object twig-logic% (send plant get-next-twig-id) plant type dir 
                    ; todo dir+rnd
                    (* width branch-width-reduction))))
      (for-each
       (lambda (twig)
         (send (cadr twig) grow))
       twigs))
    
    (define/public (add-twig point-index twig)
      (send-message 'new-twig (list 
                               (list 'plant-id (send plant get-id))
                               (list 'twig-id id)
                               (list 'point-index point-index)))
      (set! twigs (cons (list point-index twig) twigs)))
    
    (define/public (get-twig point-index)
      (cadr (assq point-index twigs)))
    
    (define/public (add-ornament point-index ornament)
      ; tell the renderer something has occurred
      (send-message 'new-ornament 
                     (list 
                      (send plant get-id)
                      id
                      point-index))
      (set! ornaments (cons (list point-index ornament) ornaments)))
    
    (define/public (get-ornament point-index)
      (cadr (assq point-index ornaments)))
    
    ; adds the ornament if it's close, and checks sub-twigs
    ; returns true if it's succeded
    (define/public (check/add-ornament pickup) 
      ; check each point in our twig
      (let ((found (foldl
                    (lambda (point found)
                      ; if we havent found anything yet and it's intersecting
                      (cond ((and (not found) (< (vdist point (send pickup get-pos)) (+ width (send pickup get-size))))
                             (add-ornament (send pickup create-ornament plant))
                             #t)
                            (else #f)))
                    #f
                    points)))
        ; now check each sub-twig
        (if (not found)
          (foldl
           (lambda (twig found) 
             (if (not found) 
                 (send twig check/add-ornament)
                 #f))
           #f
           twigs)
          found)))
      
    (define/augment (update)
      (append
       (map
        (lambda (ornament)
          (send ornament update))
        ornaments)
       (map
        (lambda (twig)
          (send (cadr twig) update))
        twigs)))
        
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; abilities live on twigs, and can do things. 
; this is the base class for all abilities.
(define ornament-logic%
  (class game-logic-object%
    (init-field
     (plant #f)        ; the plant we belong to
     (twig #f)         ; the twig we are on
     (point-index -1)) ; the index to the point on our twig
  
    (field
     (pos (send twig get-point point-index))) ; figure out the position here
    
    (define/public (get-pos)
      pos)
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pickups map to abilities, and live out in space
; this is the base class for all pickups.
(define pickup-logic%
  (class game-logic-object%
    (field
     (type 'none)
     (pos (vector 0 0 0)))
    
    (define/public (get-pos)
      pos)
    
    ; converts pickup->ormament
    ; override this 
    (define/public (create-ornament plant) 
      (make-object ornament-logic% plant)) ; todo twig/point-index???
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define plant-logic%
  (class game-logic-object%
    (init-field
     (id #f)
     (pos (vector 0 0 0)))
    
    (field
     (twigs '())     ; a assoc list map of ages to twigs
     (age 0)         ; the age of this plant
     (max-twigs 10) ; the maximum twigs allowed at any time - oldest removed first
     (next-twig-id 0))
    
    (inherit send-message)
    
    (define/public (get-id)
      id)

    (define/public (grow)
      (for-each
       (lambda (twig)
         (send twig grow))
       twigs))
    
    ; we need to maintain our list of twig ids here, for this plant
    (define/public (get-next-twig-id)
      (let ((id next-twig-id))
        (set! next-twig-id (+ next-twig-id 1))
        next-twig-id))
    
    (define/public (check/add-ornament pickup) 
      (foldl
       (lambda (twig found)
         (if (not found)
             (send twig check/add-ornament pickup)
             #f))
       #f
       twigs))
    
    (define/public (destroy-twig twig)
      0)

    ; a util to keep a fixed size list of twigs, calling destroy twig when needed.
    (define (cons-twig thing in count out)
      (cond 
        ((null? in) 
         (cons thing out))
        ((zero? count)
         (destroy-twig (car in))
         (cons thing out))
        (else (cons-twig thing (cdr in) (- count 1) (append out (list (car in)))))))
    
    (define/public (add-twig twig)
      (send twig set-id! (get-next-twig-id))
      (send-message 'new-root-twig (list 
                               (list 'plant-id id)
                               (list 'twig-id (send twig get-id))))
      (set! twigs (cons-twig twig twigs max-twigs '())))
   
    (define/augment (update)
       (map
        (lambda (twig)
          (send twig update))
        twigs))
    
    (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define game-logic%
  (class game-logic-object%
    (field
     (plants '())
     (pickups '()))
   
    (inherit send-message)
    
    (define/public (add-plant plant)
      (send-message 'new-plant '("hello"))
      (set! plants (cons plant plants)))

    (define/public (add-pickups pickup)
      (set! pickups (cons pickup pickups)))

    ; todo - distribute the checking of stuff like
    ; this to a random selection of pickups/plants
    ; to distribute the cpu load
    (define/augment (update)
      (for-each
       (lambda (pickup)
         (for-each 
          (lambda (plant)
            (send plant check/add-ormament pickup))
          plants))
       pickups)      
       (map
        (lambda (plant)
          (send plant update))
        plants))
    
    (super-new)))

(define (run)
  (let ((l (send game update)))
    (for-each
     (lambda (m)
       (send m print))
     l)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
(define game (make-object game-logic%))

(define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 1 0)))

(send game add-plant plant1)
(send game add-plant plant2)
(run)
(send plant1 add-twig (make-object twig-logic% 0 plant1 (vector 0 1 0) 1))
(run)
(for ((i (in-range 0 50)))
     (send plant1 grow)
     (run))