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 view/model client/server render/logic separation, although
; not sure if it's the right approach yet

; logic side gets ticked at a low frequency
; render side gets ticked at framerate

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a message for sending betwixt logic and render side
(define message%
  (class object%
    (init-field
     (type '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)))
    
    (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 msg)
      (set! messages (cons msg messages)))
        
    (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
          (inner ('()) 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-type)
      type)
    
    (define/public (get-dir)
      dir)
    
    (define/public (get-point point-index)
      (list-ref points point-index))
    
    (define/public (add-twig point-index twig)
      (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 (make-object 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 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
     (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
    
    (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)
      (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 '()))
   
    (define/public (add-plant plant)
      (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)))

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