;;;; 	Copyright (C) 1995 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 


(require 'Gwish)
(require 'queue)
(require 'random)


(canvas '.c)
(pack '.c :fill "both" :expand #t)
(.c 'configure :bg 'black)
(focus '.c)
(bind '.c 'Q (tcl-lambda () (wm 'withdraw ".") (destroy ".")))
(bind '.c 'q (tcl-lambda () (wm 'withdraw ".") (destroy ".")))

(define width 1500)
(define height 1100)
(wm 'geometry "." "1500x1100")
(wm 'minsize "." width height)
(wm 'maxsize "." width height)





;; Create a cyclic clock of some period which is a multiple of 2pi.
;; (time) samples and advances the clock.
;;
(define (samples from to step)
  (let loop ((answer '())
	     (at to))
    (if (< at from)
	answer
	(loop (cons at answer) (- at step)))))

;;
(define (make-circular! l)
  (let loop ((at l))
    (if (null? (cdr at))
	(begin
	  (set-cdr! at l)
	  l)
	(loop (cdr at)))))

;;
(define time
  (let* ((clock 0.0)
	 (clock-rate .1)
	 (pi (* 2 (asin 1)))
	 (clock-period (* 64 pi))
	 (timer (make-circular! (samples 0.0 clock-period clock-rate))))
    (lambda ()
      (set! timer (cdr timer))
      (car timer))))




;; Return the color for the current color.
;;
(define (color-now)
  ;; Scaled to 8 bits.
  ;;
  (define (color-scale n) (inexact->exact (* 255 (/ (+ 1 n) 2))))

  ;; number->hex-string with exactly 2 digits output for all 
  ;; unsigned 8 bit values.
  ;;
  (define (color->hex n)
    (let ((hex (number->string n 16)))
      (if (= 1 (string-length hex))
	  (string-append "0" hex)
	  hex)))

  (apply string-append
	 "#"
	 (map (lambda (c) (color->hex (color-scale c)))
	      (list (red)
		    (blue)
		    (green)))))


;; These functions compute a value in [-1.0 .. 1.0]
;; for the color components, given a clock value.
;; Have fun.
;;
(define (red) (sin (time)))
(define (blue) (sin (/ (time) 1.2)))
(define (green) (sin (/ (time) 3)))


;; Return the current dot radius.
;;
(define (radius)
  (inexact->exact (* 60 (/ (+ .5 (square (cos (/ (time) 16)))) 2))))
(define (square x) (* x x))


;; Try to keep this many dots on the screen:
;;
(define queue-len 30)

;; Put a dot, perhaps removing an old one.
;;
(define (put-dot dot-queue x y)
  (enqueue! dot-queue
	    (.c 'create 'oval
		(- x (radius)) (- y (radius))
		(+ x (radius)) (+ y (radius))
		:fill (color-now)
		))
  (if (= queue-len (queue-length dot-queue))
      (.c 'delete (dequeue! dot-queue))))


;; A stylus is a moving point, used to place
;; dots....
;;
(define (make-stylus x y)
  (let ((q (make-queue)))
    (put-dot q x y)
    (list q x y)))

;; ... A stylus can be tweaked...
;;
(define (move-stylus s dx dy)
  (put-dot (car s) (+ dx (cadr s)) (+ dy (caddr s)))
  (set-car! (cdr s) (+ dx (cadr s)))
  (set-car! (cddr s) (+ dy (caddr s))))

;; ... or set outright.
(define (set-stylus s x y)
  (move-stylus s (- x (cadr s)) (- y (caddr s))))


;; Hard-wired 2-axis symmetry.  Hmm.
;;
(define styluses
  (list (make-stylus 100 100)
	(make-stylus 100 100)
	(make-stylus 100 100)
	(make-stylus 100 100)))


;; For mouse tracking:
;;
(define cur-xy '(100 . 100))

;; Begin a real or simulated mouse gesture.
;;
(define (start-moves x y)
  (map (lambda (s) (set-stylus s x y)) styluses)
  (set! cur-xy (cons x y)))

;; Continue a real or simulated mouse gesture.
;;
(define (move-to x y)
  (let ((amt-x (- x (car cur-xy)))
	(amt-y (- y (cdr cur-xy))))
    (set! cur-xy (cons x y))
    (move-stylus (car styluses) amt-x amt-y)
    (move-stylus (caddr styluses) (- amt-x) amt-y)
    (move-stylus (cadddr styluses) amt-x (- amt-y))
    (move-stylus (cadr styluses) (- amt-x) (- amt-y))))



;; Bindings on mouse button 2 for real mouse gestures.
;;
(bind '.c "<Button-2>" (tcl-lambda ("%x %y" (number x) (number y)) (start-moves x y) ""))
(bind '.c "<B2-Motion>" (tcl-lambda ("%x %y" (number x) (number y)) (move-to x y) ""))

(let ((locked #f))
  (bind '.c "<Button-3>"
	(tcl-lambda ("%x %y" (number x) (number y))
	  (if locked
	      (set! locked #f)
	      (begin
		(start-moves x y)
		(set! locked #t)))
	  ""))
  (bind '.c "<Motion>" (tcl-lambda ("%x %y" (number x) (number y)) (if locked (move-to x y)) "")))


;; Length of the next simulated mouse gesture.
;;
(define (burst-len)
  (inexact->exact (+ 1 (/ (random queue-len) (+ 1 (random 2))))))

;; Starting position of a s.m.g.
;;
(define (burst-x) (random width))
(define (burst-y) (random height))

;; Velocity and acceleration of a s.m.g.
;;
(define (burst-vel) (- (random 10) 5))
(define (burst-dvel) (- (random 10) 5))

;; Return the path of a simulated mouse gesture from
;; initial values.  Returned as a list of points.
;;
(define (trail len x y vx vy tr)
  (if (>= 0 len)
      tr
      (trail (- len 1)
	     (+ x vx) (+ y vy)
	     (+ vx (burst-dvel)) (+ vy (burst-dvel))
	     (cons (cons (inexact->exact x) (inexact->exact y)) tr))))

;; Execute a simulated mouse gesture.
;; This isn't very interesting since it runs the whole gesture at once.
;;
(define (drop)
  (let ((t (trail (burst-len)
		  (burst-x) (burst-y)
		  (burst-vel) (burst-vel)
		  '())))
    (start-moves (caar t) (cdar t))
    (for-each (lambda (pos) (move-to (car pos) (cdr pos)) (update)) (cdr t))))




;; A queue for an incrementally issued s.m.g.
;;
(define moveq (make-queue))

;; Do one step of a simulated mouse gesture, taking the
;; next coord from moveq.  If the queue is empty, load
;; it with a new gesture and proceed.
;;
(define (drop-step)
  (if (= 0 (queue-length moveq))
      (let ((t (trail (burst-len)
		      (burst-x) (burst-y)
		      (burst-vel) (burst-vel)
		      '())))
	(start-moves (caar t) (cdar t))
	(map (lambda (pos) (enqueue! moveq pos)) (cdr t)))

      (let ((next (dequeue! moveq)))
	(move-to (car next) (cdr next))))
  #t)


;; Emergency shut-off switch...
;;
(define dodrops? #t)


;; A tcl command to do one step of an s.m.g. and then schedule
;; the next one.
;;
(proc dodrop ()
      (if dodrops?
	  (begin (after 50 'dodrop)
		 (drop-step))))

;; Start things running.
;;
(dodrop)
