; ***** IMAGE RENDERING *** ; A vertex in the figure has an x and a y coordinate. An edge is a pair ; of vertices. A line drawing is a list of edges. (defstruct vertex x y) ; *IMAGE* is the array of pixels. *IMAGE-SIZE* is its dimension. (defvar *IMAGE-SIZE* 16) (defvar *IMAGE* (make-array (list *IMAGE-SIZE* *IMAGE-SIZE*))) ; (render-lines LINES) takes a line drawing LINES and renders it in *IMAGE* (defun render-lines (LINES) (initialize-image) (mapc #'render-line LINES) (display-image) *IMAGE*) ;(initialize-image) initializes the image to be zero. (defun initialize-image () (do ((I 0 (1+ I))) ((= I *IMAGE-SIZE*)) (do ((J 0 (1+ J))) ((= J *IMAGE-SIZE*)) (setf (AREF *IMAGE* I J) 0)))) ; (render-line L) adds a single line L to the rendering of the drawing. (defun render-line (L) (let ((V1 (car L)) (V2 (cadr L))) (cond ((< (abs (- (vertex-y V2) (vertex-y V1))) (abs (- (vertex-x V2) (vertex-x V1)))) (render-line1 V1 V2 #'vertex-x #'vertex-y 'X)) (t (render-line1 V1 V2 #'vertex-y #'vertex-x 'Y))))) ; (render-line1 ...) adds a line to the image. ; The calling function render-line has identified the axis (x or y) ; in which the line has the largest change. Call this axis A and the ; other B. V1 is then the vertex with the lower coordinate in the A ; direction and V2 the vertex with the higher coordinate. COOR-A and COOR-B ; are functions to extract the coordinate in the A/B directions. DIM-A is ; either 'X or 'Y, whichever happens to be the A direction. (defun render-line1 (V1 V2 COOR-A COOR-B DIM-A) (cond ((> (funcall COOR-A V1) (funcall COOR-A V2)) (let (TMP) (setq TMP V1) (setq V1 V2) (setq V2 TMP)))) (let ((A1 (funcall COOR-A V1)) (B1 (funcall COOR-B V1)) (A2 (funcall COOR-A V2)) (B2 (funcall COOR-B V2))) (mark-image (floor A1) (floor B1) DIM-A) (let ((START (1+ (floor A1))) (STOP (floor A2)) BI (BPREV B1)) (do ((I START (1+ I))) ((> I STOP)) (setq BI (+ B1 (* (- B2 B1) (/ (- I A1) (- A2 A1))))) (mark-point I BI DIM-A) (setq BPREV BI)) (mark-image (floor A2) (floor B2) DIM-A)))) ; (mark-point I BI DIM-A) is called when it is found that a line intersects ; the point I in the A dimension and BI in the B dimension. (defun mark-point (I BI DIM-A) ; (princ (list "Mark-point" I BI DIM-A)) (terpri) (let ((BC (floor BI))) (mark-image I BC DIM-A) (mark-image (1- I) BC DIM-A))) ; (mark-image I J DIM-A) marks the image at point I in the A dimension, ; J in the B dimension. (defun mark-image (I J DIM-A) (cond ((eq DIM-A 'X) (setf (AREF *IMAGE* I J) 1)) (t (setf (AREF *IMAGE* J I) 1)))) ; display-image prints out the image. (defun display-image () (terpri) (do ((J (1- *IMAGE-SIZE*) (1- J))) ((< J 0)) (do ((I 0 (1+ I))) ((= I *IMAGE-SIZE*)) (cond ((= (AREF *IMAGE* I J) 1) (princ "O ")) (t (princ ". ")))) (terpri)) (terpri) (terpri)) ; **************************************************************** ; **** Random transformation of an image *** ; (random-depict FIGURE) subjects FIGURE to a random transformation and ; renders it in *IMAGE* (defun random-depict (FIGURE) (let ((SHAPE (random-translate (random-orient (random-scale FIGURE))))) (render-lines SHAPE))) ; (random-figure) chooses a figure at random from *FIGURES* (defun random-figure () (nth (random (length *FIGURES*)) *FIGURES*)) ; (random-scale FIGURE) subjects FIGURE to a scaling by a random factor ; between 1 and 1.5 (defun random-scale (FIGURE) (let ((SCALE (+ 1.0 (random 0.5)))) (apply-figure #'(lambda (V) (scale-vertex V SCALE)) FIGURE))) ; (random-orient FIGURE) subjects FIGURE to a rotation by a random angle ; between 0 and 2 PI. (defun random-orient (FIGURE) (let ((ANGLE (random (* 2.0 PI)))) (apply-figure #'(lambda (V) (rotate-vertex V ANGLE)) FIGURE))) ; (random-translate FIGURE) subjects FIGURE to a translation by a random ; vector that leave it in the range of *IMAGE* (defun random-translate (FIGURE) (let ((TX (random-fit (span FIGURE #'vertex-x))) (TY (random-fit (span FIGURE #'vertex-y)))) (apply-figure #'(lambda (V) (translate-vertex V TX TY)) FIGURE))) ; (apply-figure VF FIGURE) applies function VF to every vertex in FIGURE. (defun apply-figure (VF FIGURE) (mapcar #'(lambda (L) (mapcar #'(lambda (V) (funcall VF V)) L)) FIGURE)) ; (scale-vertex V SCALE) applies scaling factor SCALE to vertex V (defun scale-vertex (V SCALE) (make-vertex :x (* (vertex-x V) SCALE) :y (* (vertex-y V) SCALE))) ; (rotate-vertex V ANGLE) applies a rotation by ANGLE to vertex V. (defun rotate-vertex (V ANGLE) (make-vertex :x (- (* (vertex-x V) (cos ANGLE)) (* (vertex-y V) (sin ANGLE))) :y (+ (* (vertex-x V) (sin ANGLE)) (* (vertex-y V) (cos ANGLE))))) ;(translate-vertex V TX TY) translate vertex V by vector VX, VY (defun translate-vertex (V TX TY) (make-vertex :x (+ (vertex-x V) TX) :y (+ (vertex-y V) TY))) ; (span FIGURE F) finds the minimum and maximum values of function F over ; the vertices in FIGURE. (defun span (FIGURE F) (let ((MAX -999.0) (MIN 999.0)) (mapc #'(lambda (L) (mapc #'(lambda (V) (let ((Q (funcall F V))) (cond ((> Q MAX) (setq MAX Q))) (cond ((< Q MIN) (setq MIN Q))))) L)) FIGURE) (list MIN MAX))) ;(random-fit SPAN) is given a minimum and maximum value in SPAN and ; finds a displacement that will place SPAN within the range ; [1, *IMAGE-SIZE*] (defun random-fit (SPAN) (+ 1.0 (- (car SPAN)) (random (- *IMAGE-SIZE* (+ 1.0 (- (cadr SPAN) (car SPAN))))))) ; (sample-file FILENAME N) creates a file of the specified name with ; N random depictions of figures in *FIGURES* (defun sample-file (FILENAME N) (let ((FFF (open FILENAME :direction :output))) (setq *standard-output* FFF) (do ((I 1 (1+ I))) ((> I N)) (random-depict (random-figure))) (terpri) (setq *standard-output* *terminal-io*) (close FFF))) ;/******************************************************************/ ; Definitions of the figures in the list *FIGURES*. These should be ; self-explanatory (defun make-poly (VLIST) (mapcar #'list VLIST (append (last VLIST) VLIST))) (defun polar-vertex (R THETA) (make-vertex :x (* R (cos THETA)) :y (* R (sin THETA)))) (setq VA (make-vertex :x 0.0 :y 0.0)) (setq VB (make-vertex :x 6.0 :y 0.0)) (setq VC (make-vertex :x 6.0 :y 6.0)) (setq VD (make-vertex :x 0.0 :y 6.0)) (setq *SQUARE* (make-poly (list VA VB VC VD))) (setq VE (make-vertex :x 3.0 :y (* 3.0 (tan (* PI (/ 3.0 8.0)))))) (setq *ACUTE-TRIANGLE* (make-poly (list VA VB VE))) (setq VF (make-vertex :x 3.0 :y (* 3.0 (tan (* PI (/ 1.0 8.0)))))) (setq *OBTUSE-TRIANGLE* (make-poly (list VA VB VF))) (setq VG (make-vertex :x 4.0 :y 0.0)) (setq VH (make-vertex :x 4.0 :y 6.0)) (setq *RECT4x6* (make-poly (list VA VG VH VD))) (setq VZ (make-vertex :x 3.0 :y 0.0)) (setq VM (polar-vertex 3.0 (/ (* 1 PI) 3))) (setq VN (polar-vertex 3.0 (/ (* 2 PI) 3))) (setq VO (make-vertex :x -3.0 :y 0.0)) (setq VP (polar-vertex 3.0 (/ (* 4 PI) 3))) (setq VQ (polar-vertex 3.0 (/ (* 5 PI) 3))) (setq *HEXAGON* (make-poly (list VZ VM VN VO VP VQ))) (setq *LETTER-A* (List (list VA VE) (list VE VB) (list (make-vertex :x 1.5 :y (* 1.5 (sqrt 3.0))) (make-vertex :x 4.5 :y (* 1.5 (sqrt 3.0)))))) (setq *FIGURES* (list *SQUARE* *RECT4x6* *ACUTE-TRIANGLE* *OBTUSE-TRIANGLE* *HEXAGON* *LETTER-A*))