path: root/progs/demo/X11/graphics/henderson.hs

-- Peter Henderson's Recursive Geometry
-- Syam Gadde and Bo Whong
-- full set of modules
-- CS429 Project
-- 4/30/93

module HendersonLib (Hostname(..), Filename(..), VTriple(..), HendQuartet(..),
                     Picture(..), sendToDraw, draw, create, modify, plot) where
import Xlib

-- ADTs and Type Synonyms --------------------------------------------------
data Picture = Nil
             | Flip Picture
             | Beside Float Picture Float Picture
	     | Above Float Picture Float Picture
	     | Rot Picture
	     | File String
	     | Overlay Picture Picture
	     | Grid Int Int SegList
	     deriving Text

data Plot = Plot Picture VTriple
          | Union Plot Plot

type Hostname = String
type Filename = String
type IntPoint = (Int,Int)
type IntSegment = (IntPoint, IntPoint)
type IntSegList = [IntSegment]
type Point = (Float,Float)
type Segment = (Point, Point)
type SegList = [Segment]
type Vector = Point
type VTriple = (Vector, Vector, Vector)
type HendQuartet = (Int, Int, Int, Int)
type PEnv = [(Filename, Picture)]

-- vector Functions --------------------------------------------------------
-- for adding, negating, multiplying, and dividing vectors

addV :: Vector -> Vector -> Vector
addV (x1,y1) (x2,y2) = (x1+x2, y1+y2)

negateV :: Vector -> Vector
negateV (x,y) = (-x,-y)

multV ::  Float-> Vector -> Vector
multV a (x,y) = (a*x, a*y)

divV :: Float -> Vector -> Vector
divV a (x,y) = (x/a, y/a)

-- plot Function -----------------------------------------------------------
-- picture manipulation function

plot :: Picture -> VTriple -> PEnv -> ((Plot, PEnv) -> IO()) -> IO()

-- the Nil Picture is just "nothingness" so choose an abritrary representation
--  of nothingness.
plot Nil (v1, v2, v3) env cont = 
  plot (Grid 1 1 []) (v1,v2,v3) env cont

-- Flipping a Picture
plot (Flip p1) (v1, v2, v3) env cont = 
  plot p1 (addV v1 v2, negateV v2, v3) env cont

-- Rotate a Picture 90 degrees counterclockwise
plot (Rot p1) (v1, v2, v3) env cont = 
  plot p1 (addV v1 v3, negateV v3, v2) env cont

-- Overlay one Picture over another Picture
plot (Overlay p q) (a,b,c) env cont =
  plot p (a,b,c) env $ \ (plot1, env1) ->
  plot q (a,b,c) env1 $ \ (plot2, env2) ->
  cont ((Union plot1 plot2), env2)

-- Place p1 Beside p2 with width ratio m to n
plot (Beside m p1 n p2) (v1, v2, v3) env cont = 
  plot p1 (v1, multV (m/(m+n)) v2, v3) env $ \ (plot1, env1) ->
  plot p2 ((addV (multV (m/(m+n)) v2) v1), 
	         (multV (n/(m+n)) v2), 
                 v3) env1                  $ \ (plot2, env2) ->
  cont ((Union plot1 plot2), env2)

-- Place p Above q with height ratio m to n
plot (Above m p n q) (a,b,c) env cont =
  plot q (addV a (multV (m/(n+m)) c), b,  multV (n/(m+n)) c) env 
    $ \ (plot1, env1) ->
  plot p (a, b, multV (m/(m+n)) c) env1 $ \ (plot2, env2) ->
  cont ((Union plot1 plot2), env2)

-- the 'real' Picture
plot (Grid x y s) (a,b,c) env cont =
  cont ((Plot (Grid x y s) (a,b,c)), env)

-- this picture is located in a File with name name
--  lookup table: thanks to Sheng
plot (File name) (a,b,c) env cont =
  case (lookupEnv env name) of
    ((_, pic):_) -> plot pic (a,b,c) env cont
    []           ->
       readFile name (\s -> appendChan stdout ("File "++name++" not able to be read\n") exit done)
                     $ \s ->
       let 
        pic = read s 
        newenv = (name,pic):env
       in
       plot pic (a,b,c) newenv cont 

lookupEnv :: PEnv -> Filename -> PEnv
lookupEnv [] _ = []
lookupEnv ((a,b):es) name | a==name   = ((a,b):es)
                          | otherwise = lookupEnv es name

-- Draw Function -----------------------------------------------------------
-- user function to draw pictures 

draw :: Hostname -> Picture -> VTriple -> HendQuartet -> IO()

-- opens a display, screen, and window (of size specified in HendQuartet)
--  and draws Picture in the window
draw host p (a,b,c) (hm,hn,ho,hp) = 
 xOpenDisplay host `thenIO` \display ->       -- opens display
  let (screen:_) = xDisplayRoots display
      fg_color = xScreenBlackPixel screen
      bg_color = xScreenWhitePixel screen
      root = xScreenRoot screen
  in 
  xCreateWindow root                          -- opens window
                (XRect hm hn ho hp)
		[XWinBackground bg_color,
		 XWinEventMask (XEventMask [XKeyPress, 
		                            XExposure, 
                                            XButtonPress])]
  `thenIO` \window ->
  xSetWmName window "Henderson Graphics" `thenIO` \() ->
  xSetWmIconName window "Henderson Graphics" `thenIO` \() ->
  xMapWindow window `thenIO` \() ->          -- show window
  xDisplayForceOutput display `thenIO` \ () ->  -- show window NOW
  xCreateGcontext (XDrawWindow (xScreenRoot screen))   -- open a GC
                  [XGCBackground bg_color,
		   XGCForeground fg_color] `thenIO` \ gcontext ->
  plot p (a,b,c) [] $ \(plt,_) ->            -- make pic easier to work with
  let
    handleEvent =
      xGetEvent display `thenIO` \event ->
        case (xEventType event) of
	  -- Has a part of the window been uncovered?
	  XExposureEvent ->  sendToDraw window screen display gcontext plt
	                     `thenIO` \() -> handleEvent
          _              -> xCloseDisplay display
  in
  handleEvent

-- SendToDraw Function -----------------------------------------------------
-- called by draw to actually draw the lines onto the window

sendToDraw :: XWindow -> XScreen -> XDisplay -> XGcontext -> Plot -> IO()

-- have a Union.  so do one, and then the other. simple.
sendToDraw win screen display gcontext (Union p1 p2) = 
  sendToDraw win screen display gcontext p1 `thenIO` \() ->
  sendToDraw win screen display gcontext p2

-- have just a Plot.  have to do some dirty work.
sendToDraw window screen display gcontext (Plot (Grid x y s) (a,b,c)) = 
  let 
    v2p :: Vector -> XPoint
    v2p (e,f) = XPoint (round e) (round f)  -- convert Vector to an XPoint
    fx :: Float
    fx = fromIntegral x
    fy :: Float
    fy = fromIntegral y
    drawit :: SegList -> IO()
    -- draw the Grid one line at a time
    drawit [] = done
    drawit (((x0,y0),(x1,y1)):ss) =
      xDrawLine (XDrawWindow window) 
              gcontext 
	      (v2p (addV (addV a (multV (x0/fx) b))
	                 (multV (y0/fy) c)))
	      (v2p (addV (addV a (multV (x1/fx) b))
	                 (multV (y1/fy) c))) `thenIO` \() ->
      drawit ss
  in
  drawit s `thenIO` \ () ->
  xDisplayForceOutput display

-- create function ---------------------------------------------------------
-- opens up a window to allow the user to create a file 
-- and save it onto a file

create :: Hostname -> Filename -> Int -> Int -> IO()

create host filename x y =
  xOpenDisplay host `thenIO` \ display ->
  let 
   (screen:_) = xDisplayRoots display
   fg_color = xScreenWhitePixel screen
   bg_color = xScreenBlackPixel screen
   root = xScreenRoot screen
  in
  xCreateWindow root
                (XRect 0 0 (x+1) (y+1))
                [XWinBackground bg_color,
                 XWinEventMask (XEventMask [XExposure,
		                            XKeyPress, 
					    XButtonPress,
					    XPointerMotion])]
  `thenIO` \window ->
  xSetWmName window filename `thenIO` \() ->
  xSetWmIconName window filename `thenIO` \() ->
  xCreateWindow root
                (XRect 0 0 100 40)
		[XWinBackground bg_color] `thenIO` \window2 ->
  xSetWmName window2 "pos" `thenIO` \() ->
  xSetWmIconName window2 "pos" `thenIO` \() ->
  xMapWindow window `thenIO` \() ->
  xMapWindow window2 `thenIO` \() ->
  xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
  xCreateGcontext (XDrawWindow root)
                  [XGCBackground bg_color,
                   XGCForeground fg_color,
		   XGCFont (head fontlist)] `thenIO` \gcontext ->
  let
   handleEvent :: IntSegList -> IO()
   handleEvent list =
     xGetEvent display `thenIO` \event ->
     let 
      point = xEventPos event 
      XPoint pointx pointy = point
      handleEvent' :: XPoint -> IO()
      handleEvent' last = 
       xGetEvent display `thenIO` \event2 ->
       let 
        pos = xEventPos event2
	XPoint posx posy = pos 
       in
        case (xEventType event2) of
         XKeyPressEvent  -> 
           appendChan stdout ((show (tup pos))++ "\n") abort $
           xDrawLine (XDrawWindow window) gcontext point pos 
           `thenIO` \() -> handleEvent (store list point pos)
         XExposureEvent  -> 
           redraw window gcontext list `thenIO` \() -> handleEvent' last
	 XMotionNotifyEvent ->
	   xDrawImageGlyphs (XDrawWindow window2)
	                    gcontext
			    (XPoint 2 18)
			    ((show posx)++", "++(show posy)++"      ") 
			    `thenIO` \dummy -> handleEvent' last
         _                  -> 
           handleEvent' last
     in 
     case (xEventType event) of 
       XButtonPressEvent     -> 
         putFile display filename list x y "create"
       XKeyPressEvent  -> 
         appendChan stdout (show (tup point)) abort $ 
         handleEvent' point 
       XExposureEvent  -> 
         redraw window gcontext list `thenIO` \() -> handleEvent list
       XMotionNotifyEvent ->
	 xDrawImageGlyphs (XDrawWindow window2)
	                  gcontext
			  (XPoint 2 18)
			  ((show pointx)++", "++(show pointy)++"      ") 
			  `thenIO` \dummy -> handleEvent list
       _                  -> 
         handleEvent list
  in 
   case (checkFile filename) of 
     True  -> handleEvent []
     False -> appendChan stdout picTypeError abort $
              xCloseDisplay display

-- modify function ---------------------------------------------------------
-- allows the user to add onto an already existing picture file

modify :: Hostname -> Filename -> IO()

modify host filename =
  case (checkFile filename) of 
   False -> appendChan stdout picTypeError abort done
   True  -> 
    readFile filename (\s -> appendChan stdout 
                                        readError abort done) $ \s->
    let 
     dat = read s 
     origlist = fFloat (getlist dat)
     x = getx dat
     y = gety dat
    in
     xOpenDisplay host `thenIO` \ display ->
     let 
      (screen:_) = xDisplayRoots display
      fg_color = xScreenWhitePixel screen
      bg_color = xScreenBlackPixel screen
      root = xScreenRoot screen
     in
     xCreateWindow root
       (XRect 0 0 (x + 1) (y + 1))
        [XWinBackground bg_color,
        XWinEventMask (XEventMask [XExposure, XKeyPress, 
                                   XButtonPress, XPointerMotion])]
     `thenIO` \window ->
     xSetWmName window filename `thenIO` \() ->
     xSetWmIconName window filename `thenIO` \() ->
     xCreateWindow root (XRect 0 0 100 40)
	[XWinBackground bg_color] `thenIO` \window2 ->
     xSetWmName window2 "pos" `thenIO` \() ->
     xSetWmIconName window2 "pos" `thenIO` \() ->
     xMapWindow window `thenIO` \() -> 
     xMapWindow window2 `thenIO` \() ->
     xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
     xCreateGcontext (XDrawWindow root) [XGCBackground bg_color, 
                                         XGCForeground fg_color, 
                                         XGCFont (head fontlist)] 
     `thenIO` \ gcontext ->
    let
     handleEvent :: IntSegList -> IO()
     handleEvent list =
      xGetEvent display `thenIO` \event ->
      let 
       point = xEventPos event 
       XPoint pointx pointy = point
       handleEvent' :: XPoint -> IO()
       handleEvent' last = xGetEvent display `thenIO` \event2 ->
        let 
         pos = xEventPos event2
	 XPoint posx posy = pos 
        in
         case (xEventType event2) of
          XExposureEvent  -> 
            redraw window gcontext list `thenIO` \() -> 
            handleEvent' last
          XKeyPressEvent  -> 
            appendChan stdout ((show (tup pos))++ "\n") abort $
            xDrawLine (XDrawWindow window) gcontext point pos 
            `thenIO` \() -> handleEvent (store list point pos)
     	  XMotionNotifyEvent ->
	    xDrawImageGlyphs (XDrawWindow window2) gcontext 
             (XPoint 2 18) ((show posx)++", "++(show posy)++"      ") 
	    `thenIO` \dummy -> handleEvent' last
	  _                  -> handleEvent' last
      in
       case (xEventType event) of 
        XButtonPressEvent  ->
          putFile display filename list x y "modify"
        XKeyPressEvent     ->
          appendChan stdout (show (tup point)) abort $ 
          handleEvent' point 
        XExposureEvent  -> 
          redraw window gcontext list `thenIO` \() -> 
          handleEvent list
        XMotionNotifyEvent ->
          xDrawImageGlyphs (XDrawWindow window2) 
                           gcontext (XPoint 2 18)
           ((show pointx)++", "++(show pointy)++"      ")
          `thenIO` \dummy -> handleEvent list
        _                  -> 
          handleEvent list
    in
     redraw window gcontext origlist `thenIO` \() -> 
      handleEvent origlist

-- Miscellaneous functions -------------------------------------------------
-- shared by the create and modify functions

checkFile :: Filename -> Bool
checkFile name =
  case (take 4 (reverse name)) of
   "cip." -> True
   _      -> False

store :: IntSegList -> XPoint -> XPoint -> IntSegList 
store l a b =  [((xof a,yof a),(xof b,yof b))] ++ l

xof :: XPoint -> Int
xof (XPoint x y) = x

yof :: XPoint -> Int
yof (XPoint x y) = y

tup :: XPoint -> IntPoint
tup (XPoint a b) = (a,b)
  
ll:: IntSegment -> Int
ll ((a1,a2),(b1,b2)) = a1

lr:: IntSegment -> Int
lr ((a1,a2),(b1,b2)) = a2

rl:: IntSegment -> Int
rl ((a1,a2),(b1,b2)) = b1

rr:: IntSegment -> Int
rr ((a1,a2),(b1,b2)) = b2

getx :: Picture -> Int
getx (Grid m n o) = m

gety :: Picture -> Int
gety(Grid m n o) = n

getlist :: Picture -> SegList
getlist (Grid m n o) = o

fFloat :: SegList -> IntSegList
fFloat = map (\ ((ix,iy),(jx,jy)) ->
             ((round ix,round iy), (round jx,round jy)))

readError :: String
readError  = "Error: reading an invalid file\n"

picTypeError :: String
picTypeError = "Error: files need to be of .pic type\n"

deleteError :: String
deleteError = "Error: file can not be deleted\n"

writeError :: String
writeError = "Error: file can not be written\n"

modError :: String
modError = "Error: file can not be modified\n"

redraw :: XWindow-> XGcontext -> IntSegList -> IO()
redraw window gcontext [] = done
redraw window gcontext (l:ls) = 
 xDrawLine (XDrawWindow window) gcontext (XPoint (ll l) (lr l)) 
                                         (XPoint (rl l) (rr l))
 `thenIO` \() -> redraw window gcontext ls

changeList :: IntSegList -> SegList
changeList = 
  map (\ ((ix,iy),(jx,jy)) -> ((fromIntegral ix,fromIntegral iy),
                               (fromIntegral jx,fromIntegral jy)))

putFile :: XDisplay -> Filename -> IntSegList -> 
           Int -> Int -> String -> IO()
putFile display name list x y flag = 
 let  
  text = show (Grid x y (changeList list))
  finishMsg  = name ++ ": Done...Process completed\n"
  modMsg = name ++ ": Modifying file\n"
  createMsg = name ++ ": Creating file\n"
  continue = 
   deleteFile name (\s -> appendChan stdout deleteError abort done) $
   writeFile name text (\s -> appendChan stdout writeError abort done) $
   appendChan stdout finishMsg abort $ 
   xCloseDisplay display
 in 
  case (flag == "create") of
   False -> appendChan stdout modMsg 
                       (\s -> appendChan stdout modError abort done) $
            continue
   True  -> readFile name (\s -> appendChan stdout createMsg abort $
                                 writeFile name text abort 
                                   (xCloseDisplay display)) $ \s ->
            continue