; Stuff to make Berkeley STk's turtle act like the project's Turtle

; Filling Code
(define filling #f)

(define fill-pts '())

(define (begin-fill)
	(set! fill-pts (list (turtle-translate-x stk-xcor)
			     (turtle-translate-y stk-ycor)))
  	(set! filling #t))

(define (end-fill)
  	(if filling
	  (begin (set! filling #f)
		 (apply canvas-widget (append '(create polygon)
					      fill-pts
					      (list :fill (canvas-foreground-color))))))
		 (set! fill-pts '()))

(define (logging fn)
  	(lambda args
	  (let ((result (apply fn args)))
	    (if (and filling (not (drawing-turtle?)))
		(set! fill-pts (append fill-pts
				       (list (turtle-translate-x stk-xcor)
					     (turtle-translate-y stk-ycor)))))
	    result)))

(define internal-fd (logging internal-fd))
(define internal-setxy (logging internal-setxy))

; Circle

(define (circle radius . args)
  (if (> (length args) 1)
      (error "Too many arguments to circle")
      (let* ((extent (if (null? args) 360 (car args)))
	     (pi 3.14159)
	     (circumference (* 2.0 pi radius)))
	(if (not (= extent 0))
	  (begin (lt 1)
		 (forward (/ circumference 360.0))
		 (circle radius (- extent 1)))))))

; Names

(define (pendown)
  (set! pendown-flag #t)
  (set! penerase-flag #f))
(define pd pendown)
(define (penerase)
  (color (canvas-background-color))
  (set! pendown-flag #t)
  (set! penerase-flag #t))
(define pe penerase)

(define backward back)
(define setposition setxy)
(define setpos setxy)
(define goto setxy)
(define seth setheading)
(define clear cs)
(define color set-canvas-foreground-color)
(define begin_fill begin-fill)
(define end_fill end-fill)

; All we're missing is exitonclick and speed.

(cs)