home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / 6001 / pic-ops.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  331 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pic-ops.scm,v 1.5 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1993, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;; Operations for manipulating pictures
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-integrable (in-rect? x y width height)
  27.   (and (fix:< -1 x) (fix:< x width) (fix:< -1 y) (fix:< y height)))
  28.  
  29. (define make-pt cons)
  30. (define xcor car)
  31. (define ycor cdr)
  32.  
  33. (define (picture-overlap pic1 pic2 u v)
  34.   (let* ((wid1 (picture-width pic1))
  35.      (hgt1 (picture-height pic1))
  36.      (p1-data (picture-data pic1))
  37.      (wid2 (picture-width pic2))
  38.      (hgt2 (picture-height pic2))
  39.      (p2-data (picture-data pic2))
  40.      (u (floor->exact u))
  41.      (v (floor->exact v))
  42.      (lf (min 0 u)) 
  43.      (dn (min 0 v))
  44.      (rt (max wid2 (fix:+ wid1 u))) 
  45.      (up (max hgt2 (fix:+ hgt1 v)))
  46.      (p1x-offset (fix:- u lf))
  47.      (p1y-offset (fix:- v dn))
  48.      (new-min (min (picture-min pic1) (picture-min pic2)))
  49.      (new-pic (make-picture (fix:- rt lf) (fix:- up dn) new-min))
  50.      (new-data (picture-data new-pic)))
  51.  
  52. ;; place pic2 in its proper place on the resulting picture
  53.     (let y-loop ((y 0))
  54.       (if (fix:< y hgt2)
  55.       (let* ((p2-yth-row (vector-ref p2-data y))
  56.          (new-yth-row (vector-ref new-data (fix:- y dn)))) 
  57.         (let x-loop ((x 0))
  58.           (if (fix:< x wid2)
  59.           (begin  
  60.             (floating-vector-set! new-yth-row (fix:- x lf) 
  61.                  (floating-vector-ref p2-yth-row x))
  62.             (x-loop (fix:+ x 1)))
  63.           (y-loop (fix:+ y 1)))))))
  64.  
  65.     ;; overlay pic1 in its proper location in the result
  66.     (let y-loop ((y 0))
  67.       (if (fix:< y hgt1)
  68.       (let* ((p1-yth-row (vector-ref p1-data y))
  69.          (new-yth-row (vector-ref new-data
  70.                            (fix:+ y p1y-offset)))) 
  71.         (let x-loop ((x 0))
  72.           (if (fix:< x wid1)
  73.           (begin  
  74.             (floating-vector-set! new-yth-row (fix:+ x p1x-offset) 
  75.                  (floating-vector-ref p1-yth-row x))
  76.             (x-loop (fix:+ x 1)))
  77.           (y-loop (fix:+ y 1)))))))
  78.     (picture-set-data! new-pic new-data)
  79.     new-pic))
  80.  
  81. (define (picture-paste! pic1 pic2 u v)
  82.   (let ((wid1 (picture-width pic1))
  83.     (hgt1 (picture-height pic1))
  84.     (p1-data (picture-data pic1))
  85.     (wid2 (picture-width pic2))
  86.     (hgt2 (picture-height pic2))
  87.     (p2-data (picture-data pic2))
  88.     (u (floor->exact u))
  89.     (v (floor->exact v)))
  90.   (if (in-rect? u v wid2 hgt2)
  91.       (if (and (fix:<= (fix:+ u wid1) wid2) (fix:<= (fix:+ v hgt1) hgt2))
  92.       (let y-loop ((y 0))
  93.         (if (fix:< y hgt1)
  94.         (let ((p1-yth-row (vector-ref p1-data y))
  95.               (p2-yth-row (vector-ref p2-data (fix:+ y v))))
  96.           (let x-loop ((x 0))
  97.             (if (fix:< x wid1)
  98.             (begin
  99.               (floating-vector-set! p2-yth-row (fix:+ x u)
  100.                        (floating-vector-ref p1-yth-row x))
  101.               (x-loop (fix:+ x 1)))
  102.             (y-loop (fix:+ y 1))))))
  103.         (picture-set-data! pic2 p2-data))
  104.       (error "Picture too large -- PICTURE-PASTE!"))
  105.       (error "Coordinates out of bounds -- PICTURE-PASTE!"))))
  106.  
  107. (define (picture-cut pic u v cut-wid cut-hgt)
  108.   (let* ((wid (picture-width pic))
  109.      (hgt (picture-height pic))
  110.      (data (picture-data pic))
  111.      (u (floor->exact u))
  112.      (v (floor->exact v))
  113.      (cut-wid (floor->exact cut-wid))
  114.      (cut-hgt (floor->exact cut-hgt))
  115.      (new-pic (make-picture cut-wid cut-hgt))
  116.      (new-data (picture-data new-pic)))
  117.     (if (not (in-rect? u v wid hgt))
  118.     (error "Coordinates out of bounds -- PICTURE-CUT")) 
  119.     (if (not (fix:<= (fix:+ u cut-wid) wid)) 
  120.     (error:bad-range-argument cut-wid 'PICTURE-CUT))
  121.     (if (not (fix:<= (fix:+ v cut-hgt) hgt)) 
  122.     (error:bad-range-argument cut-hgt 'PICTURE-CUT))
  123.     (let y-loop ((y 0))
  124.       (if (fix:< y cut-hgt)
  125.       (let ((new-yth-row (vector-ref new-data y))
  126.         (old-yth-row (vector-ref data (fix:+ v y))))
  127.         (let x-loop ((x 0))
  128.           (if (fix:< x cut-wid)
  129.           (begin
  130.             (floating-vector-set! new-yth-row x
  131.                  (floating-vector-ref old-yth-row (fix:+ u x)))
  132.             (x-loop (fix:+ x 1)))
  133.           (y-loop (fix:+ y 1))))))
  134.       (picture-set-data! new-pic new-data)
  135.       new-pic)))
  136.  
  137. (define (picture-scale pic xsf ysf)
  138.   (let* ((wid (floor->exact (* xsf (picture-width pic))))
  139.      (hgt (floor->exact (* ysf (picture-height pic))))
  140.      (data (picture-data pic))
  141.      (new-pic (make-picture wid hgt))
  142.      (new-data (picture-data new-pic))
  143.      (->discrete-y (if (flo:> ysf 1.)
  144.                floor->exact
  145.                ceiling->exact))
  146.      (->discrete-x (if (flo:> xsf 1.)
  147.                floor->exact
  148.                ceiling->exact)))
  149.     (let y-loop ((ny 0) (old-y-index -1))
  150.       (if (fix:< ny hgt)
  151.       (let ((y-index (->discrete-y (/ ny ysf))))
  152.         (if (fix:= y-index old-y-index)  ; don't recompute the row
  153.         (floating-vector-set! new-data ny
  154.                  (floating-vector-copy
  155.                   (vector-ref new-data (fix:- ny 1))))
  156.         (let ((yth-row (vector-ref data y-index))
  157.               (new-yth-row (vector-ref new-data ny)))
  158.           (let x-loop ((nx 0))
  159.             (if (fix:< nx wid)
  160.             (begin
  161.               (floating-vector-set! new-yth-row nx
  162.                        (floating-vector-ref yth-row 
  163.                            (->discrete-x (/ nx xsf))))
  164.               (x-loop (fix:+ nx 1)))))))
  165.         (y-loop (fix:+ ny 1) y-index))))
  166.     (picture-set-data! new-pic new-data)
  167.     new-pic))
  168.  
  169. (define (picture-rotate pic angle)
  170.   (define (rotate-pt-by theta)
  171.     (lambda (x y)
  172.       (let ((c (cos theta)) (s (sin theta)))
  173.     (make-pt (- (* c x) (* s y))
  174.          (+ (* s x) (* c y))))))
  175.  
  176.   (define (close-enough? a b)
  177.     (fix:= (round->exact a) (round->exact b)))
  178.  
  179.   (let* ((wid (picture-width pic))
  180.      (hgt (picture-height pic))
  181.      (data (picture-data pic))
  182.      (pic-min (picture-min pic))
  183.      (lf (lo-bound wid))
  184.      (rt (fix:- (up-bound wid) 1))
  185.      (dn (lo-bound hgt))
  186.      (up (fix:- (up-bound hgt) 1))
  187.      (rotate-by-angle (rotate-pt-by angle))
  188.      (rotate-by-neg-angle (rotate-pt-by (- angle)))
  189.      (ll (rotate-by-angle lf dn))        ;rotate each
  190.      (lr (rotate-by-angle rt dn))        ;corner
  191.      (ul (rotate-by-angle lf up))        ;of the
  192.      (ur (rotate-by-angle rt up))        ;picture
  193.      (lx (min (xcor ll) (xcor lr) (xcor ul) (xcor ur)))   ;compute
  194.      (ly (min (ycor ll) (ycor lr) (ycor ul) (ycor ur)))   ;extreme
  195.      (ux (max (xcor ll) (xcor lr) (xcor ul) (xcor ur)))   ;coordinate
  196.      (uy (max (ycor ll) (ycor lr) (ycor ul) (ycor ur)))   ;values
  197.      (new-wid (round->exact (1+ (- ux lx))))
  198.      (new-hgt (round->exact (1+ (- uy ly))))
  199.      (nx-max (fix:- new-wid 1))
  200.      (ny-max (fix:- new-hgt 1))
  201.      (new-lf (lo-bound new-wid))
  202.      (new-dn (lo-bound new-hgt))
  203.      (new-pic (make-picture new-wid new-hgt))
  204.      (new-data (picture-data new-pic)))
  205.     ;; Special cases are rotations of 90 degrees (both directions) and 180
  206.     ;; degrees.
  207.  
  208.     (cond ((and (close-enough? (xcor ur) ux)    ; check for 
  209.         (close-enough? (ycor ur) uy))   ; 0 degrees
  210.        (set! new-data (make-initialized-vector
  211.                new-hgt
  212.                (lambda (n)
  213.                  (floating-vector-copy
  214.                   (vector-ref data n))))))
  215.  
  216.       ((and (close-enough? (xcor ur) lx)   ; check for 
  217.         (close-enough? (ycor ur) uy))  ; 90 degrees anti-clockwise
  218.        (let y-loop ((ny 0))
  219.          (if (fix:< ny new-hgt)
  220.          (let ((yth-row (vector-ref new-data ny)))
  221.            (let x-loop ((nx 0))
  222.              (if (fix:< nx new-wid)
  223.              (begin
  224.                (floating-vector-set! yth-row nx
  225.                     (floating-vector-ref 
  226.                      (vector-ref
  227.                       data (fix:- nx-max nx))
  228.                      ny))
  229.                (x-loop (fix:+ nx 1)))
  230.              (y-loop (fix:+ ny 1))))))))
  231.  
  232.       ((and (close-enough? (xcor ur) ux)   ; check for
  233.         (close-enough? (ycor ur) ly))  ; 90 degrees clockwise
  234.        (let y-loop ((ny 0))
  235.          (if (fix:< ny new-hgt)
  236.          (let ((yth-row (vector-ref new-data ny)))
  237.            (let x-loop ((nx 0))
  238.              (if (fix:< nx new-wid)
  239.              (begin
  240.                (floating-vector-set! yth-row nx
  241.                     (floating-vector-ref 
  242.                      (vector-ref data nx) 
  243.                      (fix:- ny-max ny)))
  244.                (x-loop (fix:+ nx 1)))
  245.              (y-loop (fix:+ ny 1))))))))
  246.  
  247.       ((and (close-enough? (xcor ur) lx)  ; check for
  248.         (close-enough? (ycor ur) ly)) ; 180 degrees
  249.        (let y-loop ((ny 0))
  250.          (if (fix:< ny new-hgt)
  251.          (begin
  252.            (floating-vector-set! new-data ny 
  253.                 (list->vector
  254.                  (reverse 
  255.                   (vector->list 
  256.                    (vector-ref data
  257.                             (fix:- ny-max ny))))))
  258.            (y-loop (fix:+ ny 1))))))
  259.  
  260.       (else
  261.        (let* ((rot-bot-lef (rotate-by-neg-angle new-lf new-dn))
  262.           (x-start (exact->inexact 
  263.                 (- (xcor rot-bot-lef) lf)))  ; in "vector 
  264.           (y-start (exact->inexact
  265.                 (- (ycor rot-bot-lef) dn)))  ; coordinates"
  266.           (c (cos angle))
  267.           (s (sin angle))) 
  268.          (let y-loop ((ny 0) (outer-x x-start) (outer-y y-start))
  269.            (if (fix:< ny new-hgt)
  270.            (let ((nyth-row (vector-ref new-data ny)))
  271.              (let x-loop ((nx 0) (inner-x outer-x) (inner-y outer-y))
  272.                (if (fix:< nx new-wid)
  273.                (let ((x (round->exact inner-x))
  274.                  (y (round->exact inner-y)))
  275.                  (floating-vector-set! nyth-row nx
  276.                       (if (in-rect? x y wid hgt)
  277.                           (floating-vector-ref
  278.                            (vector-ref data y) x)
  279.                           pic-min))
  280.                  (x-loop (fix:+ nx 1) 
  281.                      (flo:+ inner-x c) (flo:- inner-y s)))
  282.                (y-loop (fix:+ ny 1) 
  283.                    (flo:+ outer-x s) 
  284.                    (flo:+ outer-y c))))))))))
  285.     (picture-set-data! new-pic new-data)
  286.     new-pic))
  287.  
  288. (define (picture-v-reflect pic)
  289.   (let* ((wid (picture-width pic))
  290.      (hgt (picture-height pic))
  291.      (data (picture-data pic))
  292.      (new-pic (make-picture wid hgt))
  293.      (new-data (picture-data new-pic))
  294.      (y-max (fix:- hgt 1)))
  295.     (let y-loop ((y 0))
  296.       (if (fix:< y hgt)
  297.       (begin
  298.         (vector-set! new-data y 
  299.              (floating-vector-copy
  300.               (vector-ref data (fix:- y-max y))))
  301.         (y-loop (fix:+ y 1)))))
  302.     (picture-set-data! new-pic new-data)
  303.     new-pic))
  304.       
  305. (define (picture-h-reflect pic)
  306.   (let* ((wid (picture-width pic))
  307.      (hgt (picture-height pic))
  308.      (data (picture-data pic))
  309.      (new-pic (make-picture wid hgt))
  310.      (new-data (picture-data new-pic)))
  311.     (let y-loop ((y 0))
  312.       (if (fix:< y hgt)
  313.       (begin
  314.         (vector-set! new-data y
  315.              (floating-vector-reverse (vector-ref data y)))
  316.         (y-loop (fix:+ y 1)))))
  317.     (picture-set-data! new-pic new-data)
  318.     new-pic))
  319.  
  320. (define (floating-vector-reverse vector)
  321.   (let* ((length (floating-vector-length vector))
  322.      (new-vector (floating-vector-cons length))
  323.      (length-1 (- length 1)))
  324.     (do 
  325.     ((i 0 (+ i 1)))
  326.     ((= i length))
  327.       (floating-vector-set! new-vector i 
  328.                 (floating-vector-ref vector (- length-1 i))))
  329.     new-vector))
  330.  
  331.