home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / X11 / animation / r_picture.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.4 KB  |  189 lines  |  [TEXT/YHS2]
  1. {-************************************************************
  2.    MODULE R_PICTURE
  3.  
  4.      This module contains all the functions that can be used to manipulate
  5.    Pic's. The user will probably never use any of these functions. They
  6.    are used by Behaviours and such higher-order functions, which apply
  7.    these routines to all the Pic's in the list.
  8.      
  9. *************************************************************-}
  10.  
  11. module R_Picture (close_Pic, ht_Pic, wid_Pic, orig_Pic,
  12.                   overlay_Pic, put_Pic, over_Pic, above_Pic, beside_Pic,
  13.                   map_Pic,beside2_Pic,
  14.                   scale_Pic, scale_rel_Pic, mov_Pic, rot_Pic, twist_Pic,
  15.                   twist_Pic', flipx_Pic, flipy_Pic, flip_Pic, {- flock_Pic, -}
  16.                   set_Color_Pic,
  17.                   to_orig_Pic,
  18.           movto_Pic
  19.                   ) where
  20.  
  21. import R_Ptypes
  22. import R_Constants
  23. import R_Utility
  24.  
  25.   -- close_Pic makes sure that the polygon is closed
  26. close_Pic:: Pic -> Pic
  27. close_Pic p = map close_Poly p
  28.               where
  29.               close_Poly (c,ply) | (head ply) == (last ply) = (c,ply)
  30.               close_Poly (c,ply)       = (c,ply++(tail (reverse ply)))
  31.  
  32.   --these functions find the max and min x and y coordinates of a Pic
  33. maxx :: Pic -> Int
  34. maxx p = reduce max [x | (c,q) <- p, (x,y) <- q]
  35.  
  36. minx :: Pic -> Int
  37. minx p = reduce min [x | (c,q) <- p, (x,y) <- q]
  38.  
  39. maxy :: Pic -> Int
  40. maxy p = reduce max [y | (c,q) <- p, (x,y) <- q]
  41.  
  42. miny :: Pic -> Int
  43. miny p = reduce min [y | (c,q) <- p, (x,y) <- q]
  44.  
  45.   -- these functions find the height, width and origin of a Pic
  46. ht_Pic :: Pic -> Int
  47. ht_Pic p = (maxy p) - (miny p)
  48.  
  49. wid_Pic :: Pic -> Int
  50. wid_Pic p = (maxx p) - (minx p)
  51.  
  52. orig_Pic:: Pic -> Vec
  53. orig_Pic p = ( (maxx p + minx p) `div` 2, (maxy p + miny p) `div` 2 )
  54.  
  55. -- PICTURE COMBINING OPERATIONS:
  56.   
  57.   -- overlay_Pic just takes 2 Pics and puts them together into one
  58. overlay_Pic:: Pic -> Pic -> Pic
  59. overlay_Pic p q = p ++ q
  60.  
  61.   -- put_Pic overlays the Pics, offsetting the first Pic by a vector
  62.   -- amount from the origin of the second
  63. put_Pic:: Vec -> Pic -> Pic -> Pic
  64. put_Pic v p q = overlay_Pic
  65.                      (movto_Pic (vplus (orig_Pic q) v) p )
  66.                      q
  67.  
  68.   -- over_Pic puts one Pic directly on top of the other
  69. over_Pic:: Pic -> Pic -> Pic
  70. over_Pic p q = put_Pic (0,0) p q
  71.  
  72.   -- above_Pic puts the first Pic on top of the second
  73. above_Pic:: Pic -> Pic -> Pic
  74. above_Pic p q = put_Pic (0,(((ht_Pic q) + (ht_Pic p)) `div` 2)) p q
  75.  
  76.   -- beside_Pic puts the first Pic beside the second. The width of
  77.   -- the Pic is defined as the max x minus the min x, so a moving
  78.   -- figure will stand still in this implementation
  79. beside_Pic:: Pic -> Pic -> Pic
  80. beside_Pic p q = put_Pic (((wid_Pic q)+(wid_Pic p)) `div` 2, 0) p q
  81.  
  82.   -- beside2_Pic puts the first Pic beside the second, without 
  83.   -- shifting to the width of the Pic. It uses the absolute coordinates.
  84. beside2_Pic:: Pic -> Pic -> Pic
  85. beside2_Pic p q = put ((wid_Pic q), 0) p q
  86.      where put v p q = overlay_Pic (mov_Pic v p) q
  87.  
  88.  
  89.   -- The following maps a given function over the Vector-list of each Polygon:
  90. map_Pic:: (Vec -> Vec) -> Pic -> Pic
  91. map_Pic f p = map f' p
  92.               where f' (c,vs) = (c, map f vs)
  93.  
  94. -- THE GEOMETRIC TRANSFORMATIONS:
  95.  
  96.   -- scales the Pic by r, where r is in units of 11th. ie r=1, the Pic is
  97.   -- scaled by 1/11 to its origin. 
  98. scale_Pic :: Int -> Pic -> Pic
  99. scale_Pic r p
  100.    = map_Pic (scalep r) p
  101.      where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
  102.            dx = fst (orig_Pic p)
  103.            dy = snd (orig_Pic p)
  104.  
  105.   -- this is another scaling function, but it centers the image at the Vec
  106. scale_rel_Pic :: Vec -> Int -> Pic -> Pic
  107. scale_rel_Pic v r
  108.    = map_Pic (scalep r)
  109.      where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
  110.            dx = fst v
  111.            dy = snd v
  112.  
  113.   -- moves a Pic by the vector amount
  114. mov_Pic:: Vec -> Pic -> Pic
  115. mov_Pic v = map_Pic (vplus v)
  116.  
  117.   -- moves a Pic to the vector
  118. movto_Pic:: Vec -> Pic -> Pic
  119. movto_Pic v p = mov_Pic (vmin v (orig_Pic p)) p
  120.  
  121.   -- moves the origin of the Pic to the lower left side of the Pic
  122. to_orig_Pic:: Pic -> Pic
  123. to_orig_Pic p = mov_Pic (-mx,-my) p
  124.                 where mx = minx p
  125.                       my = miny p
  126.  
  127.   -- rotates the Pic about the Vector by theta
  128. rot_Pic :: Vec -> Float -> Pic -> Pic
  129. rot_Pic (a,b) theta
  130.                    = map_Pic  (rotp (a,b) theta)
  131.                      where rotp (a,b) t (v1,v2)
  132.                              = vftov (a2+ (u * cos theta - v * sin theta),
  133.                                       b2+ (u * sin theta + v * cos theta))
  134.                                 where u =  u1 -a2
  135.                                       v =  u2 -b2
  136.                       (u1,u2) = vtovf (v1,v2)
  137.                        (a2,b2) = vtovf (a,b)
  138.  
  139.   -- rotates a Pic about its origin by theta
  140. twist_Pic :: Float -> Pic -> Pic
  141. twist_Pic theta p = rot_Pic (orig_Pic p) theta p
  142.  
  143.  
  144.   -- hardwired version of rot_Pic that runs faster by rotating a set
  145.   -- unit, the rotunit, every time
  146. rot_Pic':: Vec -> Pic -> Pic
  147. rot_Pic' (a,b) = map_Pic (rotp (a,b))
  148.                  where rotp (a,b) (v1,v2)
  149.                          = vftov (a2+ (u * cosunit - v * sinunit),
  150.                                   b2+ (u * sinunit + v * cosunit))
  151.                             where u = u1-a2
  152.                                   v = u2-b2
  153.                   (u1,u2) = vtovf (v1,v2)
  154.                   (a2,b2) = vtovf (a,b)
  155.  
  156.   -- hardwired version of twist_Pic that runs faster using rot_Pic'
  157. twist_Pic':: Pic -> Pic
  158. twist_Pic' p = rot_Pic' (orig_Pic p) p
  159.  
  160.   -- flips the Pic about the line x=n (x-coordinates change)
  161. flipx_Pic :: Int -> Pic -> Pic 
  162. flipx_Pic n  = map_Pic (flipvx n)
  163.                where
  164.                flipvx n (a,b) = (2*(n-a)+a,b)
  165.  
  166.   -- flips the Pic about the line y=n (y-coordinates change)
  167. flipy_Pic :: Int -> Pic -> Pic 
  168. flipy_Pic n = map_Pic (flipvy n)
  169.               where
  170.               flipvy n (a,b) = (a, 2*(n-b)+b)
  171.  
  172.   -- flips the Pic about its own x origin.
  173. flip_Pic:: Pic -> Pic
  174. flip_Pic p = map_Pic (flipvx x) p
  175.              where (x,y) = orig_Pic p
  176.                    flipvx n (a,b) = (2*(n-a)+a,b)
  177.  
  178.   -- copies the Pic into another Pic n*n times in an n by n array pattern
  179. flock_Pic :: Int -> Pic -> Pic
  180. flock_Pic 1 p = p
  181. flock_Pic (n+2) p = beside_Pic (flock_Pic (n-1) p) (row n p)
  182.                     where row n p = replicate n above_Pic nullpic p
  183.  
  184.   -- changes the color of the Pic
  185. set_Color_Pic:: Color -> Pic -> Pic
  186. set_Color_Pic c p = map f p
  187.                     where f (c',vs) = (c,vs)
  188.  
  189.