groworld/plant-eyes/logic.ss

#lang scheme
(require scheme/class fluxus-016/fluxus "message.ss" "list-utils.ss")
(provide (all-defined-out))

(define branch-probability 6) ; as in one in branch-probability chance
(define branch-width-reduction 0.5)
(define twig-jitter 0.1)
(define branch-jitter 0.5)
(define max-twig-points 30)
(define start-twig-dist 0.05)
(define start-twig-width 0.2)
(define default-max-twigs 10)
(define default-scale-factor 1.05)
(define num-pickups 10)
(define pickup-dist-radius 200)
(define pickup-size 1)
(define ornament-grow-probability 8)
(define curl-amount 40)
(define start-size 50)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 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 (append messages (list (make-object message% name data)))))
        
    ; 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
          m
          (flatten (inner '() update))))) ; the augmented method gets called here
    
    (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
     (last-point (vector 0 0 0))      
     (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 0)            ; the width of this root
     (num-points max-twig-points) ; number of points in this twig
     (render-type 'extruded) ; the way to tell the view to render this twig
     (dist start-twig-dist)               ; distance between points          
     (parent-twig-id -1)
     (parent-twig-point-index -1))
    
    (field
     (points '())     ; the 3d points for this twig
     (widths '())
     (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
     (w 0)                ; the width of this segment
     (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly  
    
    (inherit send-message)
    
    (define/public (get-id)
      id)
    
    (define/public (set-id! s)
      (set! id s))
    
    (define/public (get-type)
      type)

    (define/public (get-dist)
      dist)
    
    (define/public (get-dir)
      dir)
    
    (define/public (get-width)
      width)
    
    (define/public (get-num-points)
      num-points)      
    
    (define/public (get-render-type)
      render-type)
    
    (define/public (get-point point-index)
      (list-ref points point-index))
    
    (define/public (get-length)
      (length points))
    
    (define/public (get-end-pos)
      (if (not (null? points))
          (list-ref points (- (get-length) 1))
          #f))
    
    (define/public (growing?)
      (< (length points) num-points))
    
    (define/public (scale a)
      (set! width (* width a))
      (set! dist (* dist a)))
        
    (define/public (grow pos)
      (when (growing?)
        (let ((new-point (if (zero? (length points))
                             ; first point should be at edge of the seed if we are a branch
                             (if (eq? parent-twig-id -1) pos 
                                 last-point)
                             pos)))         
          
          
            (set! w (* width (- 1 (/ (length points) num-points))))                  
          		  
          (set! last-point new-point)
          (set! points (append points (list new-point)))
          (set! widths (append widths (list w)))
          (send-message 'add-twig-point (list 
                                    (list 'plant-id (send plant get-id))
                                    (list 'twig-id id)
                                    (list 'point new-point)
                                    (list 'width w))))
      #;(for-each
       (lambda (twig)
         (send (cadr twig) grow ndir))
       twigs)))
    
    (define/public (get-desc-list)
       (list
          (list 'plant-id (send plant get-id))
          (list 'parent-twig-id parent-twig-id)
          (list 'point-index parent-twig-point-index)
          (list 'twig-id id)
          (list 'type type)
          (list 'dir dir)
          (list 'width width)
          (list 'num-points num-points)
          (list 'render-type render-type)))
    
    (define/public (add-twig point-index dir)
      (let ((twig (make-object twig-logic% 
                    (get-point point-index)
                      (send plant get-next-twig-id)
                      plant 
                      type 
                      dir
                      (list-ref widths point-index)
                      (quotient num-points 2)
                      render-type
                      dist
                    id
                    point-index
                    )))
      
      (send-message 'new-twig (send twig get-desc-list))
      (set! twigs (cons (list point-index twig) twigs))
        twig))
    
    (define/public (serialise)
      (append  
        (list (make-object message% 'new-twig (get-desc-list)))
        (append (map
                 (lambda (point width)
                   (make-object message% 'twig-grow (list 
                                                     (list 'plant-id (send plant get-id))
                                                     (list 'twig-id id)
                                                     (list 'point point)
                                                     (list 'width width))))
                 points widths))
        (append
         (map
          (lambda (twig)
            (send (cadr twig) serialise))
          twigs))))
    
    (define/public (get-twig point-index)
      (cadr (assq point-index twigs)))
    
    (define/public (get-random-twig)
      (if (or (null? twigs) (zero? (random 10)))
          this
          (send (cadr (choose twigs)) get-random-twig)))
    
    (define/public (add-ornament point-index ornament)
      ; todo - check max ornaments
      (send-message 'new-ornament 
                     (list 
                      (list 'plant-id (send plant get-id))
                      (list 'twig-id id)
                      (list 'point-index point-index)
                      (list 'property (send ornament get-property))))
      (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-pickup pickup) 
      ; check each point in our twig      
      (let* ((i -1) (found (foldl
                    (lambda (point found)
                      (set! i (+ i 1))
                      ; if we havent found anything yet and it's intersecting
                      (cond ((and (not found) (< (vdist (vadd (send plant get-pos) point) 
					  							(send pickup get-pos))
                                                 (+ width (send pickup get-size))))
                             (send plant add-property (send pickup get-type))
                             (send pickup pick-up) ; this will remove the pickup for us
                             (send-message 'pick-up-pickup 
                                           (list 
                                            (list 'pickup-id (send pickup get-id))))
                             #t)
                            (else #f)))
                    #f
                    points)))
        ; now check each sub-twig
        (if (not found)
          (foldl
           (lambda (twig found) 
             (if (not found) 
                 (send (cadr twig) check-pickup pickup)
                 #f))
           #f
           twigs)
          found)))
      
    (define/augment (update)
      (append
       (map
        (lambda (ornament)
          (send (cadr 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
     (id -1)
     (property 'none)
     (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-property)
      property)
    
    (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%
    (init-field
     (id -1)
     (type 'none)
     (pos (vector 0 0 0)))
    
    (field 
     (size pickup-size)
     (picked-up #f))
    
    (define/public (picked-up?)
      picked-up)
    
    (define/public (pick-up)
      (set! picked-up #t))
    
    (define/public (get-id)
      id)
    
    (define/public (get-type)
      type)
    
    (define/public (get-pos)
      pos)
    
    (define/public (get-size)
      size)
    
    (super-new)))

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

(define plant-logic%
  (class game-logic-object%
    (init-field
     (id #f)
     (pos (vector 0 0 0))
     (col (vector 1 1 1))
     (tex "fff"))
    
    (field
     (twigs '())     ; a assoc list map of ids to twigs
     (leader-twig #f) ; the temporary twig controlled by the player
     (properties '()) ; a list of symbols - properties come from pickups
     (ornaments '()) ; map of ids to ornaments on the plant
     (size start-size)         ; the age of this plant
     (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first
     (next-twig-id 0)
     (next-ornament-id 0)
     (grow-amount default-scale-factor))
    
    (inherit send-message)
    
    (define/public (get-id)
      id)

    (define/public (get-pos)
      pos)
    
    (define/public (get-size)
      size)
    
    (define/public (get-col)
      col)
    
    (define/public (get-tex)
      tex)

    (define/public (grow pos)      
      (when leader-twig
        (send leader-twig grow pos)
        (when (not (send leader-twig growing?))
          (send-message 'start-growing (list
                                        (list 'plant-id id)
                                        (list 'twig-id (send leader-twig get-id))))
          (set! leader-twig #f))))
    
    (define/public (add-property name)
      (set! properties (cons name properties)))
    
    ; 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))

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

    ; 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))
      (set! size (* size grow-amount))
      (send twig scale size)  
      (set! leader-twig twig)
      #;(send-message 'grow-seed (list 
                                (list 'plant-id id)
                                (list 'amount grow-amount)))
      (send-message 'new-twig (send twig get-desc-list))      
      (set! twigs (cons-twig twig twigs max-twigs '())))

    (define/public (add-sub-twig ptwig point-index dir)
	  	(set! leader-twig (send ptwig add-twig point-index dir))
		leader-twig)
	
    (define/public (get-random-twig)
      (if (not (null? twigs))
          (send (choose twigs) get-random-twig)
          #f))
    
    (define/public (get-twig-from-dir dir)
      (let ((dir (vnormalise dir)))
      (cadr (foldl
             (lambda (twig l)
               (let ((d (vdot (vnormalise (send twig get-dir)) dir)))
                 (if (> d (car l))
                     (list d twig)
                     l)))
             (list -99 #f)
             twigs))))
      
    (define/public (serialise)
      (append (list (make-object message% 'new-plant (list
	                                  (list 'plant-id id)
                                (list 'pos pos)
                                (list 'size size)
                                (list 'col col)
                                (list 'tex tex))))

              (append
               (map
                (lambda (twig)
                  (send twig serialise))
                twigs))))
    
    (define/augment (update)      
      ; grow a new ornament?
      (when (and (not (null? properties)) (zero? (random ornament-grow-probability)))
        (let ((twig (get-random-twig)))
          (when twig
            (let
                ((property (choose properties))
                 (point-index (+ 1 (random (- (send twig get-length) 2)))))
         
              (when (not (eq? property 'curly))
                (send twig add-ornament point-index
                                   (cond 
                                     ((or 
                                       (eq? property 'leaf)
                                       (eq? property 'wiggle))
                                     (make-object ornament-logic% 
                                        (get-next-ornament-id) 
                                        property
                                        this
                                        twig
                                        point-index))
                                     (else
                                      (error "property not understood " property)))))))))
       (map
        (lambda (twig)
          (send twig update))
        twigs))
    
    (super-new)))

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

(define game-logic%
  (class game-logic-object%
    (field
     (plants '())
     (pickups '())
     (player #f))
   
    (inherit send-message)
    
    (define/public (setup world-list)
	 (let ((pickups (list-ref world-list 1)))
	  (let ((i 0))
      (for-each
	  	(lambda (pickup)
           (add-pickup (make-object pickup-logic% i (choose (list 'leaf))
                                     (list-ref pickup 1)))
		   (set! i (+ i 1)))
		pickups))))
        
    (define/public (add-player plant)
      (printf "new player plant added ~a~n" (send plant get-id))
      (send-message 'player-plant (list
                                (list 'plant-id (send plant get-id))
                                (list 'pos (send plant get-pos))
                                (list 'size (send plant get-size))
                                (list 'col (send plant get-col))
                                (list 'tex (send plant get-tex))))
      (set! player plant)
      (set! plants (cons plant plants)))       
     
    (define/public (add-plant plant)
      (send-message 'new-plant (list
                                (list 'plant-id (send plant get-id))
                                (list 'pos (send plant get-pos))
                                (list 'size (send plant get-size))
                                (list 'col (send plant get-col))
                                (list 'tex (send plant get-tex))))
      (set! plants (cons plant plants)))
    
    (define/public (add-pickup pickup)
                            (send-message 'new-pickup
                                      (list
                                       (list 'pickup-id (send pickup get-id))
                                       (list 'type (send pickup get-type))
                                       (list 'pos (send pickup get-pos))))
      (set! pickups (cons pickup pickups)))
   
    (define/public (serialise)
      (send player serialise))
    
    ; 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-pickup pickup))
          plants))
       pickups)      
      
      ; remove the pickups that have been 'picked up'
      (set! pickups (filter 
                     (lambda (pickup)
                       (not (send pickup picked-up?)))
                     pickups))
      
       (map
        (lambda (plant)
          (send plant update))
        plants))
    
    (super-new)))