groworld/plant-eyes/scripts/logic.ss

;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]

#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 start-twig-points 15)
(define start-twig-dist 0.05)
(define start-twig-width 0.1)
(define default-max-twigs 2)
(define default-scale-factor 1.05)
(define num-pickups 10)
(define pickup-dist-radius 200)
(define pickup-size 1)
(define ornament-grow-probability 2)
(define curl-amount 40)
(define start-size 50)
(define max-ornaments 10) ; per twig
(define nutrient-twig-size-increase 2)
(define num-worms 10)
(define num-spiders 10)
(define num-butterflies 10)
(define auto-twig-var 5)
(define auto-time 5)
(define pickup-check-prob 20)

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 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 t d) ; need to augement this if we have child logic objects, 
      (let ((l (inner '() update t d)) ; and call update on them too.
	        (m messages))    
        (set! messages '())        
         (append
          m
          (flatten l)))) ; the augmented method gets called here
    
    (super-new)))

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

(define insect-logic%
    (class game-logic-object%
        (init-field
            (id 0)
            (pos 0)
			(type 'none)
            (d (if (eq? type 'worm) (+ 20 (* 20 (rndf)))
									(+ 10 (* 2 (rndf)))))) ; time to get from one place to another
        
        (field
            (next-update 0)
			(centre (vector 0 0 0)))
 
        (inherit send-message)
       
        (define/public (get-id)
            id)
        
        (define/public (get-pos)
            pos)
      
	    (define/public (get-type)
            type)
			
		(define/public (set-centre s)
			(set! centre s))
        
        (define (move)
			; todo check stones	
			(let ((speed (if (eq? type 'worm) 5 50)))
			(if (> (vdist pos centre) 100)
            	(set! pos (vadd pos (vmul (vnormalise (vsub centre pos)) speed)))
			    (set! pos (vadd pos (vmul (srndvec) speed))))
			;(when (< (vdist pos centre) 12) (move))
			(when (and (or (eq? type 'spider) (eq? type 'worm)) (> (vy pos) 0))
				(set! pos (vector (vx pos) 0 (vz pos))))
			(when (and (eq? type 'butterfly) (< (vy pos) 50))
				(set! pos (vector (vx pos) 50 (vz pos))))))
        
        (define/augment (update time delta)
            (cond ((> time next-update)
                    (move)
					; todo: drop stuff
                    ;(when (zero? (random pickup-drop-probability))
                    ;    (send cell set-pickup! 'default))
                    (set! next-update (+ time d))
					(send-message 'insect-move (list 
                                    (list 'insect-id id)
									(list 'pos pos)
									(list 'duration d)))))
			'())
        
        (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 start-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-w)
		w)
	
    (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 (if (zero? (- num-points 2)) width 
			 (* width (- 1 (/ (length points) (- num-points 2))))))
			 (set! dist (* w 1.5))
          (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))))))
    
    (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)
	  (when (< (length ornaments) 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))
                                                 10 #;(+ 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 t d)	  
      (append
       (map
        (lambda (ornament)
          (send (cadr ornament) update t d))
        ornaments)
       (map
        (lambda (twig)
          (send (cadr twig) update t d))
        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")
	 (is-player #f))
    
    (field
     (twigs '())     ; a assoc list map of ids to twigs
     (leader-twig #f) ; the temporary twig controlled by the player
     (properties '(flower)) ; 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)
	 (twig-size start-twig-points)
	 (auto-pilot-t 0)
	 (auto-pilot-d (* (+ 1 (rndf)) auto-time))
	 (auto-twig #f)
	 (auto-twig-dir (hsrndvec))
	 (auto-twig-pos (vector 0 0 0)))
    
    (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 (get-twig-size)
	  twig-size)

    (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)
	  (if (eq? name 'nutrient)
	     (set! twig-size (+ twig-size nutrient-twig-size-increase))
         (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) 
	  (when (or is-player (random pickup-check-prob)) ; reduce the frequency for non-player plants
		  (when leader-twig 
		    (send leader-twig check-pickup pickup))
	
      #;(foldl
       (lambda (twig found)
         (if (not found)
		     (when (send (cadr twig) growing?)
               (send (cadr twig) check-pickup pickup))
             #f))
       #f
       twigs)))
	   
    (define/public (destroy-twig twig)
	   (send-message 'shrink-twig
		   	(list (list 'plant-id id)
			      (list 'twig-id (send (cadr twig) get-id))))
	   #;(send-message 'destroy-branch-twig (list
									(list 'plant-id id)
									(list 'twig-id (send (cadr 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 (list (send twig get-id) 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 (cadr (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 (cadr twig) get-dir)) dir)))
                 (if (> d (car l))
                     (list d (cadr 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 (cadr twig) serialise))
                twigs))))
    
	(define/public (run-auto-pilot t d)
		(when (> t auto-pilot-t)
			(set! auto-pilot-t (+ t auto-pilot-d))
			(when (or (not auto-twig) (not (send auto-twig growing?)))
				(set! auto-twig (make-object twig-logic%  (vector 0 0 0) 0 this 'root 
                                    	auto-twig-dir
                                    	start-twig-width 
										twig-size
										'ribbon))
				(set! auto-twig-dir (hsrndvec))
				(set! auto-twig-pos auto-twig-dir)
				(add-twig auto-twig))
			(set! auto-twig-dir (vmul (vnormalise (vadd auto-twig-dir (vmul (srndvec) auto-twig-var))) 
					(send auto-twig get-dist)))
			(set! auto-twig-pos (vadd auto-twig-pos auto-twig-dir))
			(grow auto-twig-pos)))
	
    (define/augment (update t d)      
      ; grow a new ornament?
      (when (and (not (null? properties)) (zero? (random ornament-grow-probability)))
        (let ((twig (get-random-twig)))
          (when (and twig (> (send twig get-length) 3) (not (send twig growing?)))
            (let
                ((property (choose properties))
                 (point-index (+ 1 (random (- (send twig get-length) 2)))))
         
                (send twig add-ornament point-index
                                     (make-object ornament-logic% 
                                        (get-next-ornament-id) 
                                        property
                                        this
                                        twig
                                        point-index))))))									 
       (map
        (lambda (twig)
          (send (cadr twig) update t d))
        twigs))
    
    (super-new)))

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

(define game-logic%
  (class game-logic-object%
    (field
     (plants '())
     (pickups '())
     (player #f)
	 (insects '()))
   
    (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 (list-ref pickup 0)
                                     (list-ref pickup 2)))
           (set! i (+ i 1)))
        pickups)
	  (for ((id (in-range 0 num-worms)))
		(add-insect (make-object insect-logic% id (vmul (srndvec) 100) 'worm)))
	  (for ((id (in-range 0 num-spiders)))
		(add-insect (make-object insect-logic% (+ id num-worms) (vmul (srndvec) 100) 'spider)))
	  (for ((id (in-range 0 num-butterflies)))
		(add-insect (make-object insect-logic% (+ id num-worms num-butterflies) (vmul (srndvec) 100) 'butterfly)))
	  	)))
        
    (define/public (add-player plant)
      (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))
	  
	  (for-each 
	  	(lambda (insect)
			(send insect set-centre (send plant get-pos)))
			insects))
     
    (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 (add-insect insect)
      (send-message 'new-insect (list
                                (list 'insect-id (send insect get-id))
                                (list 'pos (send insect get-pos))
                                (list 'type (send insect get-type))))
		(send insect set-centre (send player get-pos))
      (set! insects (cons insect insects)))
   
    (define/public (serialise)
      (send player serialise))
	  
	  
	(define/public (run-auto-pilot t d)
		(for-each
		  (lambda (plant)
		  	(when (not (eq? plant player))
				(send plant run-auto-pilot t d)))							
			plants))
		  
    
    ; todo - distribute the checking of stuff like
    ; this to a random selection of pickups/plants
    ; to distribute the cpu load
    (define/augment (update t d) 
	
	  (run-auto-pilot t d)       
	     
      (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))
      
	    (append
		(map
         (lambda (plant)
           (send plant update t d))
         plants)
		 (map
		 	(lambda (insect)
				(send insect update t d))
			insects)))
    
    (super-new)))