groworld/sketcher/sketch-lsys.scm

202 lines
7.5 KiB
Scheme
Raw Normal View History

2009-05-01 20:34:29 +00:00
;------------------------------------------------------
; lsystem sketching prototype
; ---------------------------
;
; an idea for putting lsystems under human control,
; and making them sketchable.
; not sure how this would be best extended to 3D.
; [I need to work on the mouse stuff in fluxus]
;
; instructions:
; * draw from the centre by dragging with left mouse
; * repeat to make a new plant/drawing
;
; don't make the drawing too long, it'll make your computer cry
(require "ls.ss")
; gets a line representing a segment of the projection of the mouse into 3D space
; should move this into the fluxus scheme library
(define (get-line-from-mouse)
(let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) 2)
(* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) 1.5) -1))
(scrpos2 (vtransform (vmul ndcpos 50) (minverse (get-camera-transform))))
(scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
(list scrpos scrpos2)))
; we'll just use the end of the projection line here
(define (mouse-pos)
(cadr (get-line-from-mouse)))
; converts a 2D vector into an angle, with some dodgy dave maths
(define (2dvec->angle x y)
(let ((q (/ 3.141 2)))
(when (zero? y) (set! y 0.0001))
(cond
((>= y 0)
(fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
(else
(fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))
;-----------------------------------------------------
; builds objects from a string
; would be good to abstract this asap
(define (ls-build string angle branch-scale branch-col leaf-col)
(hint-depth-sort)
(for-each
(lambda (char)
(cond
((char=? #\F char)
(with-state
(translate (vector 1 0 0))
(translate (vmul (crndvec) 0.01))
(scale (vector 1.2 2 2))
(rotate (vector 0 90 0))
(colour (vector 0.5 1 0.2))
(with-primitive (build-ribbon 2)
; (texture (load-texture "textures/fade4.png"))
; (hint-unlit)
(pdata-set! "w" 0 0.1)
(pdata-set! "w" 1 0.1)
(pdata-set! "p" 0 (vector 0 0 1))
(pdata-set! "p" 1 (vector 0 0 0))))
(translate (vector 1 0 0)))
((char=? #\L char)
#; (with-state
(translate (vector 1 0 0))
(scale (vector 2 1 1))
; (rotate (vector 0 90 0))
(colour leaf-col)
(texture (load-texture "../textures/leaf.png"))
(build-plane))
(translate (vector 1 0 0)))
((char=? #\f char)
(translate (vector 1 0 0)))
((char=? #\/ char)
(rotate (vector angle 0 0)))
((char=? #\\ char)
(rotate (vector (- angle) 0 0)))
((char=? #\+ char)
(rotate (vector 0 angle 0)))
((char=? #\- char)
(rotate (vector 0 (- angle) 0)))
((char=? #\^ char)
(rotate (vector 0 0 angle)))
((char=? #\& char)
(rotate (vector 0 0 (- angle))))
((char=? #\| char)
(rotate (vector 0 0 180)))
((char=? #\[ char)
(push)
(scale (vector branch-scale branch-scale branch-scale)))
((char=? #\] char)
(pop))))
(string->list string)))
;------------------------------------------------------
; strokes are collections of points representing mouse movement
(define-struct stroke ((points #:mutable)))
(define (build-stroke)
(make-stroke (list (vector 0 0 -40)))) ; start with a point in the middle of the screen
(define (stroke-clear stroke)
(set-stroke-points! stroke (list (vector 0 0 -40))))
(define (stroke-add stroke pos)
(set-stroke-points! stroke (cons pos (stroke-points stroke))))
(define (stroke-last-point stroke)
(car (stroke-points stroke)))
(define (stroke-update stroke)
; make a new point when the mouse is suitibly far from the last point
(when (> (vdist (stroke-last-point stroke) (mouse-pos)) 2)
(stroke-add stroke (mouse-pos))))
; draw some blobs to indicate the path drawn
(define (stroke-render stroke)
(for-each
(lambda (pos)
(with-state
(opacity 0.7)
(translate pos)
(hint-unlit)
(colour (vector 1 1 0))
(draw-sphere)))
(stroke-points stroke)))
; converts a stroke into the corresponding lsystem string,
; with some branchpoints to recurse the drawing - would be
; better to get the branchpoints from the drawing somehow...
(define (stroke->string stroke angle)
(define (collect pos next-pos last-angle str c)
(cond ((null? next-pos) str)
(else
(let* ((v (vsub (car pos) (car next-pos)))
(a (2dvec->angle (vx v) (vy v))) ; get the absolute angle
(ra (- a last-angle)) ; get angle relative to the last angle
; make a string which represents this turn
(new-str (if (> ra 0) ; which way are we turning?
(make-string (inexact->exact (round (/ ra angle))) #\-)
(make-string (inexact->exact (round (abs (/ ra angle)))) #\+)))
(out (if (zero? (modulo c 10))
(string-append str new-str "F") ; add branch
(string-append str new-str "F")))) ; normal
(collect (cdr pos) (cdr next-pos) a out (+ c 1))))))
(collect
(reverse (stroke-points stroke))
(cdr (reverse (stroke-points stroke))) 0 "" 0))
;------------------------------------------------------
; a fluxus mouse pointer!
(define (draw-mouse)
(with-state
(translate (mouse-pos))
(hint-unlit)
(colour (vector 1 0.4 0.3))
(draw-sphere)))
(define stroke (build-stroke))
(define root (build-locator))
(define debounce #t)
(define (animate)
(draw-mouse)
(when (mouse-button 1) (stroke-update stroke))
(stroke-render stroke)
(when (and (not debounce) (not (mouse-button 1)))
(display (stroke->string stroke 45))(newline)
(with-state
(parent root)
; (translate (vector 0 -30 -40))
(scale 0.75)
(rotate (vector 90 90 0))
(ls-build
(lsystem-generate 4 "A" (list (list "A" "B[----AB][++++AB]")
(list "B" (stroke->string stroke 10))))
10 0.75 (vector 1 1 1) (vector 1 1 1)))
(set! debounce #t))
(when (and debounce (mouse-button 1))
(set! debounce #f)
(stroke-clear stroke)
(destroy root)
(set! root (build-locator))))
(clear)
(clear-colour (vector 0.2 0.4 0.3))
(set-camera-transform (mtranslate (vector 0 0 -10)))
(light-diffuse 0 (vector 0 0 0))
(define l (make-light 'point 'free))
(light-diffuse l (vector 1 1 1))
(light-position l (vector -50 50 0))
(every-frame (animate))