diff options
Diffstat (limited to 'progs/demo/X11/graphics/henderson.hs')
| -rw-r--r-- | progs/demo/X11/graphics/henderson.hs | 465 |
1 files changed, 465 insertions, 0 deletions
diff --git a/progs/demo/X11/graphics/henderson.hs b/progs/demo/X11/graphics/henderson.hs new file mode 100644 index 0000000..8b7e4ce --- /dev/null +++ b/progs/demo/X11/graphics/henderson.hs @@ -0,0 +1,465 @@ +-- 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 + + + + |