Re: Koch Figures - LTK package

Nice!

The function you are looking for is (clear canvas). Anyway I strongly recommend that you put programs you write into packages, it helps keeping symbols sorted out. Besides recreating lines, if you have a recent Ltk, it is easier just to set the coords of a line instance to the new values via (setf (coords line) values). For demonstration I have added xxx2 functions which use this mechanism. The setf coords function is rather intelligent, so just passing it your vector of conses does work :)

Peter

here the code:
-----------------------------------------------------

(defpackage "KOCH"
  (:use :common-lisp
	:ltk)
  (:export
   #:koch-window
   #:koch-window2))

(in-package :koch)


(defun x (pt) (car pt))
(defun y (pt) (cdr pt))
(defun point (x y) (cons x y))
(defun xr (pt) (round (car pt)))
(defun yr (pt) (round (cdr pt)))

(defun dibujar-linea (A B canvas)
  (create-line canvas (list (xr A) (yr A) (xr B) (yr B))))

(defconstant +tan60+ (tan (/ pi 3)))

(defun punto-a-un-tercio-entre (A B)
  "Yields the point at one third the distance between A and B."
  (point (/ (+ (x B) (* 2 (x A))) 3)
	 (/ (+ (y B) (* 2 (y A))) 3)))

(defun punto-equilatero (A B)
  "Yields the point that forms an equilateral triangle with A and B."
  (let ((D (point (/ (+ (x A) (x B)) 2)
		  (/ (+ (y A) (y B)) 2))))
    (point (- (x D) (* +tan60+ (- (y D) (y A))))
	   (+ (y D) (* +tan60+ (- (x D) (x A)))))))

(defun koch (puntos canvas check-b)
  (let ((puntos-nuevos (make-array (1+ (* 4 (1- (length puntos))))
:fill-pointer 0)))
    (dotimes (i (1- (length puntos)))
      (let* ((A  (elt puntos i))
	     (B  (elt puntos (1+ i)))
	     (A1 (punto-a-un-tercio-entre A B))
	     (B1 (punto-a-un-tercio-entre B A)))
	(dibujar-linea A B canvas)
	(vector-push A puntos-nuevos)
	(vector-push A1 puntos-nuevos)
	(vector-push (punto-equilatero B1 A1) puntos-nuevos)
	(vector-push B1 puntos-nuevos)))
    (vector-push (elt puntos (1- (length puntos))) puntos-nuevos)
    (when (= (value check-b) 1) (clear canvas))
    (koch puntos-nuevos canvas check-b)))

(defun koch-window ()
  (with-ltk ()
    (let* ((sc (make-instance 'scrolled-canvas))
	   (c  (canvas sc))
	   (f  (make-instance 'frame))
	   (cb (make-instance 'check-button
			      :master f
			      :text "Erase-mode"))
	   (bc (make-instance 'button
			      :master f
			      :text "Koch Curve"
			      :command (lambda ()
					 (koch (vector (point 100 250)
						       (point 500 250)) c cb))))
	   (bt (make-instance 'button
			      :master f
			      :text "Koch Triangle"
			      :command (lambda ()
					 (koch (vector (point 500 400)
						       (point 100 400)
						       (punto-equilatero (point 500 400) (point 100 400))
						       (point 500 400)) c cb)))))
      (pack f)
      (pack bc :side :left)
      (pack bt :side :left)
      (pack cb :side :left)
      (pack sc :expand 1 :fill :both)
      (configure f :borderwidth 2)
      (configure f :relief :groove))))



(defun koch2 (puntos canvas line)
  (let ((puntos-nuevos (make-array (1+ (* 4 (1- (length puntos))))
:fill-pointer 0)))
    (dotimes (i (1- (length puntos)))
      (let* ((A  (elt puntos i))
	     (B  (elt puntos (1+ i)))
	     (A1 (punto-a-un-tercio-entre A B))
	     (B1 (punto-a-un-tercio-entre B A)))
	(vector-push A puntos-nuevos)
	(vector-push A1 puntos-nuevos)
	(vector-push (punto-equilatero B1 A1) puntos-nuevos)
	(vector-push B1 puntos-nuevos)))
    (vector-push (elt puntos (1- (length puntos))) puntos-nuevos)
    (setf (ltk::coords line) puntos-nuevos)
    (koch2 puntos-nuevos canvas line)))

(defun koch-window2 ()
(with-ltk ()
(let* ((sc (make-instance 'scrolled-canvas))
(c (canvas sc))
(f (make-instance 'frame))
(cb (make-instance 'check-button
:master f
:text "Erase-mode"))
(bc (make-instance 'button
:master f
:text "Koch Curve"
:command (lambda ()
(koch2 (vector (point 100 250)
(point 500 250)) c (make-line c '(100 250 500 250))))))
(bt (make-instance 'button
:master f
:text "Koch Triangle"
:command (lambda ()
(koch2 (vector (point 500 400)
(point 100 400)
(punto-equilatero (point 500 400) (point 100 400))
(point 500 400)) c (make-line c '(500 400 100 400 500 400)))))))
(pack f)
(pack bc :side :left)
(pack bt :side :left)
(pack cb :side :left)
(pack sc :expand 1 :fill :both)
(configure f :borderwidth 2)
(configure f :relief :groove))))




--
Ltk, the easy lisp gui http://www.peter-herth.de/ltk/
.