202 lines
7.5 KiB
Scheme
202 lines
7.5 KiB
Scheme
;------------------------------------------------------
|
|
; 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))
|