diff options
Diffstat (limited to 'progs/demo/X11')
72 files changed, 6202 insertions, 0 deletions
diff --git a/progs/demo/X11/animation/README b/progs/demo/X11/animation/README new file mode 100644 index 0000000..c14b867 --- /dev/null +++ b/progs/demo/X11/animation/README @@ -0,0 +1,22 @@ +In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya +proposes an approach to animation that uses functional languages. As +Arya describes, the cost of computing power is falling. This is making +the use of computer animation much more prevalent. However, languages +such as C make it difficult to program animations. What is needed is +a simpler, faster and more accessible way to program graphics. Functional +languages are a very effective means for this, due to their higher order +functions. + + Kevi Arya goes on to provide such a functional animation package in +the language Miranda. Haskell in particular is good functional language for +two reasons. It is a completely functional language, doing even I/O in a +functional manner. Variables are evaluated in a lazy manner allowing infinite +lists to be manipulated easily, which suits the infinite frames format +of animation. + +The following animations are provided here: + + seaside.hs - a seaside scene + planets.hs - planets in orbit + palm.hs - another seaside scene + birds.hs - flying birds diff --git a/progs/demo/X11/animation/animation.hs b/progs/demo/X11/animation/animation.hs new file mode 100644 index 0000000..3c0750c --- /dev/null +++ b/progs/demo/X11/animation/animation.hs @@ -0,0 +1,16 @@ +-- This bundles all the animation stuff into a single module. + +module Animation(R_Ptypes..,R_Constants..,R_Utility..,R_Picture..,R_Behaviour.., + R_Movie..,R_Shapes..,R_Defaults..,R_Inbetween.., + R_Display..) where +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour +import R_Movie +import R_Shapes +import R_Defaults +import R_Inbetween +import R_Display + diff --git a/progs/demo/X11/animation/animation.hu b/progs/demo/X11/animation/animation.hu new file mode 100644 index 0000000..0dd71ee --- /dev/null +++ b/progs/demo/X11/animation/animation.hu @@ -0,0 +1,6 @@ +animation.hs +r_movie.hu +r_defaults.hu +r_shapes.hu +r_inbetween.hu +r_display.hu diff --git a/progs/demo/X11/animation/birds.hs b/progs/demo/X11/animation/birds.hs new file mode 100644 index 0000000..daba730 --- /dev/null +++ b/progs/demo/X11/animation/birds.hs @@ -0,0 +1,28 @@ +module Birds where + +import Animation + +bird :: Movie +--bird = osc [bird1,bird2] +bird = rOVERLAY + [apply (bPar [right,right,right,right]) bm1, + apply (bPar [up,right,right,right]) bm2] + where bm1 = osc [bird1] + bm2 = osc [bird2] + +bird1 = [(black,b1)] + where b1 = [(0,90),(20,100),(30,110),(40,110),(50,100),(110,120), + (130,100),(120,90),(80,90),(0,90), + (80,90),(90,70),(140,50),(120,90),(80,90), + (80,90),(70,70),(80,60),(90,70)] + +bird2 = [(red,b2)] + where b2 = [(0,60),(20,70),(30,80),(40,80),(50,70),(110,70), + (140,30),(110,35),(100,35),(70,50),(50,60),(0,60), + (70,50),(100,90),(150,100),(120,60),(110,35), + (70,50),(65,100),(85,115),(97,86)] + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 bird) + + diff --git a/progs/demo/X11/animation/birds.hu b/progs/demo/X11/animation/birds.hu new file mode 100644 index 0000000..cd94b30 --- /dev/null +++ b/progs/demo/X11/animation/birds.hu @@ -0,0 +1,3 @@ +:o= all +birds.hs +animation.hu diff --git a/progs/demo/X11/animation/doc.tex b/progs/demo/X11/animation/doc.tex new file mode 100644 index 0000000..1b66751 --- /dev/null +++ b/progs/demo/X11/animation/doc.tex @@ -0,0 +1,578 @@ + +% This is obsolete regarding the X system -- jcp + +% -*-latex-*- +% Creator: John Tinmouth +% Creation Date: Thu May 9 1991 +\documentstyle[11pt]{article} +\newcommand{\X}[1]{{#1}\index{{#1}}} +\begin{document} + +\title{A Functional Animation Package in Haskell} +\author{ + John Tinmouth\\ + Computer Science Senior Project\\ + Yale University\\ + Professor Paul Hudak } +\date{9 May 1991} +\maketitle + + + +\section{Introduction} + + In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya +proposes an approach to animation that uses functional languages. As +Arya describes, the cost of computing power is falling. This is making +the use of computer animation much more prevalent. However, languages +such as C make it difficult to program animations. What is needed is +a simpler, faster and more accessible way to program graphics. Functional +languages are a very effective means for this, due to their higher order +functions. + + Kevi Arya goes on to provide such a functional animation package in +the language Miranda. Haskell in particular is good functional language for +two reasons. It is a completely functional language, doing even I/O in a +functional manner. Variables are evaluated in a lazy manner allowing infinite +lists to be manipulated easily, which suits the infinite frames format +of animation. As it is now possible to complete the implementation of +this package is Haskell, my work has been converting these Miranda programs +to Haskell version 1.0-0, Yale Haskell Group. + + + +\section{How to Use the Graphics: Overview} + + By using higher order functions, it becomes very easy to do rapid +prototyping of animations. You can quickly throw out an animation of +simple images manipulated in simple ways. For example, if there was +an image of a car, and you wanted it to move left, you could almost +just describe it in english, and that would be the animation. +\begin{verbatim} + movie = apply left car +\end{verbatim} + + After the simple model is done, converting it to a more complex model +is simple. Simply make the image, "car" in this case, more complex, and +then modify the "left" function, and you are done. + + There are three stages in making a movie. First of all, you must +define your basic images. These will tend to be Pics put into lists, either +finite or infinite, to be basic Movies. Second, you decide precisely +what kind of motion you want in animation. These are behaviours. A behaviour +modifies a movie over time, changing each successive frame. This includes +motion, changing size, changing from one image to another and so forth. These +are applied to your basic Movies. Third, you must combine your basic Movies +into your final Movie. If you want a scene of clouds and a man walking, you +must overlay your basic Movie of clouds with your Movie of a walking man. + +\section {Original Images or Pics} + + A Movie is a list of frames called Pics. Each of these Pics is a list +of colored polygons. The Pic is a Color followed by a list of Vectors, +representing the vertices of the Polygon. The original Pic usually must +be entered by hand, although simple generation routines for boxes, +triangles and circles are available. You need to produce some of these +basic images in one way or another, so that you have something to +manipulate. + + To make a Movie, you need a list of these Pics. With a single Pic, you +can generate a sequence of that Pic. With several Pics, you can oscillate +through the Pics in an inifinite list. To generate an infinite list of +Pics of p1, define a Movie, m1 = i p1. + The following datatypes are used in this package: + +\begin{verbatim} +type Vec = (Int,Int) +type Color = Int +type Poly = (Color,[Vec]) +type Pic = [Poly] +type Movie = [Pic] +type Behaviour = [Pic -> Pic] +\end{verbatim} + + +\subsection {Modifying Pics} + + Starting with a single Pic, it is possible to create a short list of +Pics to oscillate on. You can flip it, scale it, or otherwise modify the +original Pic (p1) in some way to create another Pic (p2). You can either +keep doing this and produce N images for a Movie of [p1,p2,...,pN], or use +the interpolation functions available to shift from p1 to p2 in N frames, +resulting in a Movie [p1,interp1,interp2,...,interpN-2,p2]. + The list of specific Pic-to-Pic functions is included in the next section, +along with short explanations of what they do. + +\subsection {Pic-to-Pic Functions Available} + +\begin{verbatim} +overlay_Pic Args: Pic Pic + This takes 2 Pics and just puts them together into one Pic. + module: R_Picture + +put_Pic Args: Vec Pic Pic + This overlays the two Pics, putting Pic-1's center the Vec + distance away from Pic-2's center. + module: R_Picture + +over_Pic Args: Pic Pic + This puts two images on top of one another, explicitly + centering the first on top of the second and forms one Pic. + module: R_Picture + +above_Pic Args: Pic Pic + This puts the first Pic above the second Pic, at a distance + of half the combined heights of the Pics and overlays them + to form one Pic. + module: R_Picture + +beside_Pic Args: Pic Pic + This puts the first Pic to the right of the second Pic, at + a distance of half the combined widths of the Pics and + overlays them to form one Pic. + module: R_Picture + +beside2_Pic Args: Pic Pic + Withouth analysing the widths of the Pics, it puts the + first Pic the width of the second Pic to the right and + overlays them to form one Pic. + module: R_Picture + +scale_Pic Args: Int Pic + This scales the picture in elevenths around its own origin + and returns that Pic. So if the Int is 22, the Pic will + scaled by a factor of 2 (22/11). + module: R_Picture + +scale_rel_Pic Args: Vev Int Pic + This is another scaling function, but it scales the image + from the Vec, treating it as the origin. + module: R_Picture + +mov_Pic Args: Vec Pic + This moves the Pic by the amount of the vector. + module: R_Picture + +movto_Pic Args: Vec Pic + This moves the Pic's center to the Vec. + module: R_Picture + +to_orig Args: Pic + This moves the Pic's center to the lower,left side of + the Pic. + module: R_Picture + +rot_Pic Args: Vec Float Pic + This rotates the Pic by the Float in radians, using the Vec + as the origin of rotation. + module: R_Picture + +twist_Pic Args: Float Pic + This rotates the Pic by the Float amount of radians around + its own center. + module: R_Picture + +rot_Pic' Args: Vec Pic + This rotates the Pic by a certain amount (set in R_Constants) + using the Vec as the center of rotation. The set amount of + rotation makes it faster than rot_Pic. + module: R_Picture + +twist_Pic' Args: Pic + This rotates the Pic by a certain amoutn (set in R_Constants) + around the Pic's origin. The set amount of rotation makes + it faster than twist_Pic. + module: R_Picture + +flipx_Pic Args: Int Pic + This flips the Pic around the line x=Int, essentially giving + a mirror image of the Pic, reversing right and left. + module: R_Picture + + +flipy_Pic Args: Int Pic + This flips the Pic around the line y=Int, mirror-imaging the + Pic, reversing up and down. + module: R_Picture + +flip_Pic Args: Pic + This flips the Pic around its own x-origin, reversing + left and right. + module: R_Picture + +flock_Pic Args: Int Pic + This takes the image Pic and copies it out Int*Int times in + a Int by Int grid pattern, and returns that as an Pic. + module: R_Picture + +set_Color Args: Int Pic + This takes an Int standing for a color, and changes the + color of the Pic to that. + module: R_Picture +\end{verbatim} + +\subsection{Other Functions for Manipulating Pics} + +\begin{verbatim} +i Args: Any + This will take anything and return an infinite stream of them. + module: R_Utility + +osc Args: [Any] + This will take a Movie, which is a list of Pics and + oscillate them. + [p1] will give [p1,p1,p1,p1....] + [p1,p2,p3,p4] will give [p1,p2,p3,p4,p3,p2,p1,p2...] + module: R_Utility +\end{verbatim} + +\section{Behaviours and their Application to Movies} + + A Behaviour is a list of functions that will convert one Pic to +another Pic. This list then can be applied to any Movie with one +of the application functions (most often apply). The beauty of the Behaviour +is that once you have a behaviour for moving left, you can move any +Movie left without rewriting the routine every time. + + There are specific functions that take a Behaviour and a Movie and +return a new Movie. These are apply and while. If you had a Movie of a +man walking in place, and a Behaviour called left that moves Pics ever +increasing distances left, then you could create a man walking left by: +\begin{verbatim} + apply left man +\end{verbatim} + + If you want to apply more than one Behaviour to a Movie, you must first +decide whether to do that in sequence or in parallel, and use bSeq and bPar +to reduce the list of Behaviours to a single Behaviour, and then apply +that to a movie. For example: +\begin{verbatim} + apply (bPar left up) gull +\end{verbatim} +will take a Movie of a gull and move the Pics up and left. + + Most of the basic Behaviours are defined in R\_Behaviour. + + +\subsection{Defining Customized Packages of Behaviours} + + Often you will have more specialized, or just simpler Behaviours you +want to use. Using the Behaviours and Pic-to-Pic functions, it is very +easy to create your own small library of Behaviours. R\_Defaults is a +module of such Behaviours. For example, to create a Behaviour to move +a Movie right, you would create a list of mov\_Pic's, each taking a +everincreasingly large x-coordinate. +\begin{verbatim} + right = [ mov_Pic (x,y) | (x,y) <- zip [0,10,..] [0,..] ] +\end{verbatim} + + Or if you wanted a behavour to place a Movie at (100,100) twice as +large as before, you could create a new Behaviour from old ones as: + scaleat= bPar [movto (i (100,100)), scale (i 22)] + +\subsection{Behaviours Available} +\begin{verbatim} +flip Args: none + This will flip every Pic around its x-origin, resulting in + mirror images reversing left and right. + module: R_Behaviour + +twist' Args: none + This will rotate each Pic by the amount rotunit (see + R_Constants) around its origin. + module: R_Behaviour + +mov Args: [Vec] + This will move each Pic by its corresponding vector. + module: R_Behaviour + +movto Args: [Vec] + This will move each Pic's origin to its corresponding vector. + module: R_Behaviour + +circ_mov Args: Float Float + This will move each Pic in a circle, of radius of the first + Float and by an increment of the second Float, using (0,0) + as the origin of rotation. + module: R_Behaviour + +scale Args: [Int] + Scales every Pic on its origin by the the corresponding Int + in the list. These Ints represents elevenths, so that a + [2,2,...] will scale every Pic by 2/11 . + module: R_Behaviour + +scale_rel Args: Vec [Int] + Same as scale, except that the Pics are all scaled using the + Vec as the point of origin. + module: R_Behaviour + +twist Args: [Float] + This will rotate every Pic by its corresponding Float from + the list in radians. + module: R_Behaviour + +set_color Args: [Int] + This sets each Pic to the color indicated by its + corresponding int in the list. + module: R_Behaviour + +rot Args: [Vec] [Float] + This will rotate each Pic around its corresponding Vec by + its corresponding Float in radians. + module: R_Behaviour + +big Args: none + Scales every Pic up by scaleunit + module: R_Defaults + +huge Args: none + This scales every Pic up by 2*scaleunit + module: R_Defaults + +small Args: none + This scales every Pic down by 10/11 + module: R_Defaults + +tiny Args: none + This scale every Pic down by 5/11 + module: R_Defaults + +bigger Args: none + This scales every Pic in the list by scaleunit more + than the previous Pic, so that the n-th element is + scaled up by (n-1)*scaleunit + module: R_Defaults + +smaller Args: none + This scales every Pic down, so that the n-th element + is scaled down by (n-1)*(10/11) + module: R_Defaults + +ccw Args: none + This rotates every Pic by one rotunit more than the + previous Pic, in a counterclockwise fashion. + module: R_Defaults + +cw Args: none + This rotates every Pic by one rotunit more than the + previous Pic, in a clockwise fashion. + module: R_Defaults + +up Args: none + This moves every Pic up by one unit more than the + Previous Pic, so that the n-th element is moved up + (n-1) units. + module: R_Defaults + +down Args: none + This is same as up, but the Pics move down. + module: R_Defaults + +right Args: none + This is same as up, but the Pics move right. + module: R_Defaults + +left Args: none + This is same as up, but the Pics move left. + module: R_Defaults +\end{verbatim} + +\subsection{Functions For Behaviours} + +\begin{verbatim} +do Args: Int Behaviour + This takes the first Int elements of the Behaviour and + return that. + module: R_Behaviour + +rpt Args: Int Behaviour + This takes an Int and returns a Behaviour of length Int. + However, the n-th Pic-to-Pic in the Behaviour returned + is made up of the first through (n-1)the Pic-to-Pics of + the input list. + module: R_Behaviour + +forever Args: Behaviour + This makes a finite Behaviour list an infinite one by + appending the list to itself endlessly. + module: R_Behaviour + +apply Args: Behaviour Movie + This takes a Behaviour and applies it to a Movie + module: R_Behaviour + +while Args: (Boolean function) Behaviour Movie + As long as the Boolean function evaluates true, this + takes a Behaviour and applies it to a Movie. When it + evaluates to false, no more Pics are produced and + the Movie is cut short there. + module: R_Behaviour + +bseq Args: Behaviour Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in sequence. + module: R_Behaviour + +bSeq Args: [Behaviour] Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in sequence. + module: R_Behaviour + +bpar Args: Behaviour Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in parallel. + module: R_Behaviour + +bPar Args: [Behaviour] Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in parallel. + module: R_Behaviour +\end{verbatim} + +\section{Creating the Final Movie} + + Finally, you have your basic Movies made up of Pictures and Behaviours. +Now you need to combine them into one Movie. The functions that do this +are found in the module R\_Movie. These functions will take a list of +Movies and return a single Movie combining all the Movies in the list. +How they are combined can be controlled to some extent. Usually they are +just overlayed, but they can be put beside one another, or on top of +one another, or put a Vec distance apart. + + It is also possible to use a combination of these forms. If you wanted +to overaly M1 and M2, and then put that beside M3, you would do: +\begin{verbatim} + rBESIDE [M3, rOVERLAY [M1,M2] ] +\end{verbatim} +This is acceptable as rOVERLAY will return a single Movie. + +\subsection{Movie Combining Functions} + +\begin{verbatim} +rABOVE Args: [Movie] + Puts all the Movies into one movie, all above one another. + module: R_Movie + +rBESIDE Args: [Movie] + Puts all the Movies into one movie, all beside one another. + module: R_Movie + +rBESIDE2 Args: [Movie] + Using their absolute coordinates, puts all the Movies + beside one another. + module: R_Movie + +rOVER Args: [Movie] + This lays the Movies on top of one another, centering + each Pic so that they share the same origin. + module: R_Movie + +rOVERLAY Args: [Movie] + This lays the Movies on top of one another, centering + each Pic so that they share the smae origin. + module: R_Movie + +pUT Args: [Vec] Movie Movie + This takes a list of Vec, and puts each Pic of the + first Movie in the location of the corresponding + Vec on top of the Pic of the second Movie and + returns that list as the new Movie. + module: R_Movie + +\end{verbatim} + +\section{Displaying Your Movie} + + Once you have your function for the Movie defined, you need to output +it in some way. Currently, this is done by outputting characters to a file and +running a C Program in X-Windows that displays the contents of the file +as a graphic in the X system. First of all, you must convert the +Movie variable to a stream of characters. This is done by running +"showm" on the Movie. Be carefull you don't try to convert an infinite list +into characters as the compiler will take awhile to do this. Instead, take +a certain number of frames and convert them with "showm". +\begin{verbatim} + man\_vm = rOVERLAY [man,vm] + man\_vmstring = showm (take 20 man&vm) +\end{verbatim} + Now that you have this string, you need to write it to disk. The +"writetofile" function does this. It takes a characater string(ie [Char] ) +as an argument, and then prompts you for a filename. It then writes the +string to the filename. So to put man\_vm string into a file: +\begin{verbatim} + main = writetofile man_vmstring +\end{verbatim} +and run the program, where you will prompted for the filename. Or you could: +\begin{verbatim} + main = writetofile (showm (take 20 man_vm)) +\end{verbatim} +to make it more compact. + + +\subsection{Miscellaneous Usefull Functions} + +\begin{verbatim} +inbetween Args: Int Pic Pic + This takes an Int and two Pics and returns a Movie + with Int Pics interpolating between the two Pics. + module: R_Inbetween + +tween Args: Int Movie Movie + This takes an Int and two Movies and returns one + Movie made up of the first Movie, Int number of + frames of Pics interpolating between the last + Pic of the first Movie and the first Pic of the + second Movie, followed by the second Movie + module: R_Inbetween + +box Args: Int Int Int + This takes 3 Ints, the color, width and height of + the box and returns a Pic of a box + module: R_Shapes + +tri Args: Int Vec Vec Vec + This takes a color and three vectors and returns a + Pic of a triangle of that colour with those vertices. + module: R_Shapes + +circ Args: Int Int Int + This takes a color, the radius and the number of points + around the circle, and returns a circle with origin at + (0,0). + module: R_Shapes +\end{verbatim} + +\pagebreak +\large {\bf Appendix: C Programs to Display on X-Windows} +\\ +\\ + The program currently used to run these graphics is called "xcshow". +This takes one argument, the name of the file to be run. When run +in X-Windows, it will produce a window with the first Pic. To run it, click +on the left mouse button inside the window. Clicking again will freeze it. +This will keep cycling through the file, replaying again when it hits the +end of the file, until the window is killed. + + There is also "xshow" which is used to run the monochrome Movies, as +"xcshow" is used to run the color Movies. As this animation package +only produces color Movies, it isn't too usefull. + + +\pagebreak +\large {\bf References} +\\ +\\ +\begin{verbatim} +[ARYA88] "The Formal Analysis of a Functiona Animation System", Kevi Arya, + DPhil,Thesis,Oxford University, Programming Research Group, + April 1988 + +[ARYA89] "Processes In A Functional Animation System", Kevi Arya,IBM + T.J. Research Center, 1989 + +[HASK90] "Report On The Programming Language Haskell, Version 1.0", + YALEU/DCS/RR-777,Yale University,1990 +\end{verbatim} + +\end{document} diff --git a/progs/demo/X11/animation/palm.hs b/progs/demo/X11/animation/palm.hs new file mode 100644 index 0000000..9deef12 --- /dev/null +++ b/progs/demo/X11/animation/palm.hs @@ -0,0 +1,47 @@ +module Palm (main) where + +import Animation +import SeaFigs + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 trans) + +trans :: Movie +trans = manright++change++gull2 + +manright::Movie +manright = mirrorx (take 10 (apply left man)) + +gull2::Movie +gull2 = apply (bPar [right,up,huge,huge,huge,(mov (i (275,0)))]) gull + +change::Movie +change = inbetween 5 manf1 gull1 + where gull1 = head gull2 + manf1 = last manright + + + +mirrorx :: Movie -> Movie +mirrorx m = map (flipx_Pic x) m + where (x,_)=orig_Movie m + + +orig_Movie :: Movie -> Vec +orig_Movie m = ((x2-x1) `div` 2,(y2-y1) `div` 2) + where x2 = reduce max (map maxx m) + x1 = reduce min (map minx m) + y2 = reduce max (map maxy m) + y1 = reduce min (map miny m) + +maxx :: Pic -> Int +maxx p = reduce max [x | (c,q) <- p, (x,y) <- q] + +minx :: Pic -> Int +minx p = reduce min [x | (c,q) <- p, (x,y) <- q] + +maxy :: Pic -> Int +maxy p = reduce max [y | (c,q) <- p, (x,y) <- q] + +miny :: Pic -> Int +miny p = reduce min [y | (c,q) <- p, (x,y) <- q] diff --git a/progs/demo/X11/animation/palm.hu b/progs/demo/X11/animation/palm.hu new file mode 100644 index 0000000..a86fcb9 --- /dev/null +++ b/progs/demo/X11/animation/palm.hu @@ -0,0 +1,3 @@ +:o= all +palm.hs +seafigs.hu diff --git a/progs/demo/X11/animation/planets.hs b/progs/demo/X11/animation/planets.hs new file mode 100644 index 0000000..38f278a --- /dev/null +++ b/progs/demo/X11/animation/planets.hs @@ -0,0 +1,30 @@ +module Planets (main) where + +import Animation + +planets:: Float -> Float -> Int -> Int -> Int -> Int -> Movie +planets i1 i2 r1 r2 c1 c2 + = rOVERLAY + [ apply f1 earth, + apply (bpar f1 f2) moon + ] + where f1 = circ_mov (fromIntegral r1) i1 + f2 = circ_mov (fromIntegral r2) i2 + earth = osc [mov_Pic (vplus center (r1,0)) (box c1 30 30)] + moon = osc [mov_Pic (vplus center (r1+r2,0)) (box c2 15 15)] + +gen a b c d = c :(gen a b (c+b) d) + + +planet_scene:: Movie +planet_scene = rOVERLAY + [apply (bpar (set_color (i yellow)) (movto (i center))) orb, + planets (pi/40.0) (pi/10.0) 450 80 darkblue lightblue, + planets (pi/20.0) (pi/8.0) 300 50 brown black, + planets (pi/10.0) (pi/4.0) 150 40 green red + ] + +orb = osc [circ red 50 10] + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 60 planet_scene) diff --git a/progs/demo/X11/animation/planets.hu b/progs/demo/X11/animation/planets.hu new file mode 100644 index 0000000..3473372 --- /dev/null +++ b/progs/demo/X11/animation/planets.hu @@ -0,0 +1,3 @@ +:o= all +planets.hs +animation.hu diff --git a/progs/demo/X11/animation/r_behaviour.hs b/progs/demo/X11/animation/r_behaviour.hs new file mode 100644 index 0000000..6f58e3b --- /dev/null +++ b/progs/demo/X11/animation/r_behaviour.hs @@ -0,0 +1,158 @@ +{-********************************************************************** + MODULE R_BEHAVIOUR + + This module defines the basic Behaviours available to manipulate + Movies. These functions can either be used directly, or used to + easily create personnalized Behaviours (see R_Defaults). + There are the Behaviours that affect one Movie, which are mov,movto + circ_mov,scale,scale_rel,rot,flip and set_color. These change some + aspect of the movie over time. + There are functions that combine several movies into one, namely + bseq,bSeq,bpar and bPar. + Some functions modify the Behaviours. These are do, rpt and forever. + They put limits on how long the Behaviour is. + Finally, there are the functions that apply the Behaviours to a Movie. + These are apply and while. Apply applies a Behaviour to a Movie until + it runs out of Movie or Behaviour. While takes a conditional and + applies the Behaviour to it until that condition is fullfilled. + +***********************************************************************-} + +module R_Behaviour (mov,movto,circ_mov,scale,scale_rel,rot,flipb, + set_color, + bseq,bSeq,bpar,bPar, + do,rpt,forever, + apply,while ) where + +import R_Ptypes +import R_Utility +import R_Picture + + -- takes a Pic to Pic and makes an infinite list Behaviour out of it +makeb1 :: (Pic->Pic) -> Behaviour +makeb1 f = f : makeb1 f + + -- takes a movie and flips it around the x-origin using flip_Pic +flipb :: Behaviour +flipb = makeb1 flip_Pic + + -- twist makes twist_Pic into a Behaviour, rotating the image by rotunit +twist' :: Behaviour +twist' = makeb1 twist_Pic' + + -- makeb2 makes a Behaviour out of a function that takes a list and a + -- function and outputs a Behaviour. +makeb2 :: (a->Pic->Pic) -> [a] -> Behaviour +makeb2 f [] = [] +makeb2 f (v:vs) = f v : makeb2 f vs + + -- mov takes a list of Vec's and applies each Pic-to-Pic in the Behaviour + -- list to its corresponding Vec, and gives back a new Behaviour +mov :: [Vec] ->Behaviour +mov = makeb2 mov_Pic + + -- movto creates a list of Pic-to-Pic Behaviours that move each Pic to its + -- corresponding Vec +movto :: [Vec] -> Behaviour +movto = makeb2 movto_Pic + + -- produces a Behaviour that produces movement in a circle, taking + -- the radius and the increment as arguments. +circ_mov :: Float -> Float -> Behaviour +circ_mov r inc = mov (map (vmin' (head vs')) vs') + where vs = [ (r*(cos theta),r*(sin theta)) | + theta <- gen inc 0.0 ] + vmin' x y = vmin y x + vs' = map vftov vs + +gen :: Float -> Float -> [Float] +gen b c = c : (gen b (c+b) ) + + + -- scale outputs a list of Pic-to-Pic's that scale according to its + -- corresponding Int in the input list +scale :: [Int] -> Behaviour +scale = makeb2 scale_Pic + + -- scale_rel does the same thing, but centers on the lower-left corner of + -- the image +scale_rel :: Vec -> [Int] -> Behaviour +scale_rel v = makeb2 (scale_rel_Pic v) + + -- twist outputs a list of Behaviours that rotate each pick by its + -- corresponding Float in the list +twist :: [Float] -> Behaviour +twist = makeb2 twist_Pic + + -- set_color takes a list of Colors, and returns a list of Pic-to-Pic's + -- that change to the corresponding color in the list +set_color :: [Color] -> Behaviour +set_color = makeb2 set_Color_Pic + + -- makeb3 takes a function with two inputs, and two input lists and + -- returns a behaviour made up of functions with inputs fromt the lists +makeb3 :: (a->b->Pic->Pic) -> [a] -> [b] -> Behaviour +makeb3 f [] (p:ps) = [] +makeb3 f (v:vs) [] = [] +makeb3 f (v:vs) (p:ps) = f v p : makeb3 f vs ps + + -- rot produces behaviours rotating by the Float, around the point + -- of the Vec, both provided by lists. +rot :: [Vec] -> [Float] -> Behaviour +rot = makeb3 rot_Pic + + -- bseq takes two Behaviours and combines them into one, in sequence. + -- It first applies all of the first Behaviour, then all of the second +bseq :: Behaviour -> Behaviour -> Behaviour +bseq ps [] = [] +bseq [] qs = [] +bseq ps qs = ps ++ (mapc (last ps) qs) + + -- bSeq takes a list of Behaviour and makes them into one Behaviour, in + -- sequence. +bSeq :: [Behaviour] -> Behaviour +bSeq = reduce bseq + + -- bpar takes two behaviours and applies them both simultaneously, + -- producing a list of Pic-to-Pic's, each one made up of a function + -- from the first list combined with a function from the second list +bpar :: Behaviour -> Behaviour -> Behaviour +bpar [] (q:qs) = [] +bpar (p:ps) [] = [] +bpar (p:ps) (q:qs) = (p.q):(bpar ps qs) + + -- bPar takes a list of Behaviours and makes them all into one Behaviour, + -- in paralell +bPar :: [Behaviour] -> Behaviour +bPar = reduce bpar + + -- takes the first n POic-to-Pics in a Behaviour and returns that Behaviour +do :: Int -> Behaviour -> Behaviour +do n f = take n f + + -- applies bseq to the list of behaviours, so that the nth element of + -- the returned list has n-1 behaviours in it, applied in sequence +rpt :: Int -> Behaviour -> Behaviour +rpt n f = replicate n bseq [] f + + -- takes the behaviour and applies all the behaviours up the nth element + -- to the nth element, in an infinite list +forever :: Behaviour -> Behaviour +forever f = bseq f (forever f) + + -- takes a behaviour, applies each from to a Pic in a Movie and returns + -- the new Movie +apply :: Behaviour -> Movie -> Movie +apply [] ms = [] +apply fs [] = [] +apply (f:fs) (m:ms) = (f m):(apply fs ms) + + -- applies the Behaviour to the Movie until the condition is fullfilled, + -- then returns the movie to that point +while :: (Pic -> Bool) -> Behaviour -> Movie -> Movie +while c [] ms = [] +while c fs [] = [] +while c (f:fs) (m:ms) = if (c m) then ( (f m):(while c fs ms)) + else [] + + diff --git a/progs/demo/X11/animation/r_behaviour.hu b/progs/demo/X11/animation/r_behaviour.hu new file mode 100644 index 0000000..afa52bb --- /dev/null +++ b/progs/demo/X11/animation/r_behaviour.hu @@ -0,0 +1,3 @@ +:o= all +r_behaviour.hs +r_picture.hu diff --git a/progs/demo/X11/animation/r_constants.hs b/progs/demo/X11/animation/r_constants.hs new file mode 100644 index 0000000..f36e3f2 --- /dev/null +++ b/progs/demo/X11/animation/r_constants.hs @@ -0,0 +1,129 @@ +{-**************************************************************** + MODULE R_CONSTANTS + + This module sets up all the constants used in this functional + animation package. + Defined here are the basic units of movement, scale and rotation. + The screen height and width are set, and the various parts of + the screen such as the top-middle, lower-left and center are + all set. Finally the color values used by xcshow, the c-program + that displays the movies in X, are set. + +******************************************************************-} + +module R_Constants (fps, unit, hf, qt, scaleunit, rotunit, + nullpic, nullseq, + sinunit,cosunit, + screenwid, screenht, botl, leftm, topl, topm, topr, + rightm, botr, botm, center, + white,black,red,green,darkblue,lightblue,brown,yellow, + colorName, allColors + ) where + +import R_Ptypes + + -- units are set. The scaleunit is in 11th, so that the 12 is + -- actually 12/11'ths +fps :: Int +unit :: Int +hf :: Int +qt :: Int +scaleunit :: Int +fps = 25 +unit = 15 +hf = unit `div` 2 +qt = unit `div`4 +scaleunit = 12 + --scaleunit is div'ed by 12 later + +rotunit :: Float +rotunit = pi/18 +sinunit = sin rotunit +cosunit = cos rotunit + + +nullpic :: Pic +nullpic = [] +nullseq :: Movie +nullseq= nullpic : [ nullseq2 | nullseq2 <- nullseq] + + -- Screen Parameters +screenwid :: Int +screenwid = 800 +screenht :: Int +screenht = 800 + +botl :: Vec +leftm :: Vec +topl :: Vec +topm :: Vec +topr :: Vec +rightm :: Vec +botr :: Vec +botm :: Vec +center :: Vec + +leftmb :: Vec +leftmt :: Vec +topml :: Vec +topmr :: Vec +rightmt :: Vec +rightmb :: Vec +botml :: Vec +botmr :: Vec + +botl = ( 0, 0 ) +leftm = ( 0, screenht `div` 2) +topl = ( 0, screenht ) +topm = ( screenwid `div` 2, screenht ) +topr = ( screenwid, screenht ) +rightm = ( screenwid, screenht `div` 2 ) +botr = ( screenwid, 0 ) +botm = ( screenwid `div` 2, 0 ) +center = ( screenwid `div` 2, screenht `div` 2 ) + +leftmb = ( 0, screenht `div` 4 ) +leftmt = ( 0, (screenht*3) `div` 4 ) +topml = ( screenwid `div` 4, screenht ) +topmr = ( (screenwid*3) `div` 4, screenht ) +rightmt = ( screenwid, (screenht*3) `div` 4 ) +rightmb = ( screenwid, screenht `div` 4 ) +botml = ( screenwid `div` 4, 0 ) +botmr = ( (screenwid*3) `div` 4, 0 ) + + -- Colors values set to names + +white :: Color +white = 1 +black :: Color +black = 2 +red :: Color +red = 4 +green :: Color +green = 6 +darkblue :: Color +darkblue = 8 +lightblue :: Color +lightblue = 10 +yellow :: Color +yellow = 12 +brown :: Color +brown = 14 + +colorName :: Color -> String +colorName 1 = "white" +colorName 2 = "black" +colorName 4 = "red" +colorName 6 = "green" +colorName 8 = "blue" +colorName 10 = "lightblue" +colorName 12 = "yellow" +colorName 14 = "brown" + +allColors :: [Color] +allColors = [1,2,4,6,8,10,12,14] + + + + + diff --git a/progs/demo/X11/animation/r_constants.hu b/progs/demo/X11/animation/r_constants.hu new file mode 100644 index 0000000..d61580f --- /dev/null +++ b/progs/demo/X11/animation/r_constants.hu @@ -0,0 +1,3 @@ +:o= all +r_constants.hs +r_ptypes.hu diff --git a/progs/demo/X11/animation/r_curve.hs b/progs/demo/X11/animation/r_curve.hs new file mode 100644 index 0000000..14d288c --- /dev/null +++ b/progs/demo/X11/animation/r_curve.hs @@ -0,0 +1,60 @@ +{-************************************************************** + MODULE R_CURVE + + This module produces sequences of numbers to be used by + Behaviours. The sequences used for moving or scaling can + be produced here, in either linear sequences or accelerating + and decelerating sequences. + The acceleration functions produce floats, so the vftov function + would have to be used to convert floating point vectors to integer + vectors. + +***************************************************************-} + +module R_Curve(lnr,hold, acc, dec, accdec, decacc) where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour + + -- lnr takes the start, finish and the number of intervals and + -- produces a linear list of ints going from the start to finish. +lnr :: Int -> Int -> Int ->[Int] +lnr start fin n = take n [start,(start+step)..] + where step = ((fin-start)`div`(n-1)) + + -- hold produces an infinite number of ints starting at v, modified + -- by step every time. +hold :: Int -> Int -> [Int] +hold v step = [v,v+step..] + + -- acc accelerates from 0 to the max in n steps. +acc :: Int -> Int -> Int -> [Int] +acc min max n = min:acc' min (max-min) n 1 + +acc' :: Int -> Int -> Int -> Int -> [Int] +acc' min max n c | (c>n) = [] +acc' min max n c = (min + (((max*c*c) `div` (n*n)))) + : (acc' min max n (c+1)) + + + -- dec decelerates from the max to 0 in n steps. +dec :: Int -> Int -> Int -> [Int] +dec min max n = reverse (acc min max n) + + -- accdec accelerates from start up to max and back to fin, in an steps + -- accelerating and dn steps decelerating +accdec :: Int -> Int -> Int -> Int -> Int -> [Int] +accdec start max fin an dn = (acc start max an)++(tail (dec fin max dn)) + + -- decacc decelerates from start to min in dn steps and then accelerates + -- back up to fin in an more steps +decacc :: Int -> Int -> Int -> Int -> Int -> [Int] +decacc start min fin dn an = (dec min start dn)++(tail (acc min fin an)) + + + + + diff --git a/progs/demo/X11/animation/r_curve.hu b/progs/demo/X11/animation/r_curve.hu new file mode 100644 index 0000000..9aa9629 --- /dev/null +++ b/progs/demo/X11/animation/r_curve.hu @@ -0,0 +1,3 @@ +:o= all +r_curve.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_defaults.hs b/progs/demo/X11/animation/r_defaults.hs new file mode 100644 index 0000000..1b7070a --- /dev/null +++ b/progs/demo/X11/animation/r_defaults.hs @@ -0,0 +1,76 @@ +{-**************************************************************** + MODULE R_DEFAULTS + + This module uses the R_Behaviour module to define convient and + easy to use behaviours. These aren't very sophistated, but they + can be used to quickly animate a movie. For more sophistated + animation, a similiar library of sophistocated personnalized + functions can be created. + +******************************************************************-} + +module R_Defaults (big, huge, bigger, smaller, ccw, cw, + up, down, left, right,small,tiny) +where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour + + + -- big scales everything up by the scaleunit (now 12/11ths) +big :: Behaviour +big = [scale_Pic x | x <- [scaleunit,scaleunit..]] + + -- huge scales everything up by twice the scaleunit (24/11ths) +huge :: Behaviour +huge= [scale_Pic x | x <- [scaleunit*2,(scaleunit*2)..]] + + -- small scales everything down by 10/11ths +small :: Behaviour +small = [scale_Pic x | x <- [s,s..]] + where s = 10 + + -- tiny scales everything down by 5/11ths +tiny :: Behaviour +tiny = [scale_Pic x | x <- [s,s..]] + where s = 5 + + -- bigger causes the Pics to be scaled up by 12/11ths,24/11ths,36/11ths + -- and so on, everincreasing. +bigger :: Behaviour +bigger = [scale_Pic x | x <- (rept (\x -> div (x*scaleunit) 11) 1)] + + -- smaller causes the Pics to be scaled downwards in ever decreasing + -- amounts. +smaller :: Behaviour +smaller = [scale_Pic x | x <- (rept (\x -> div (x*10) 11) 1)] + + -- a hardwired version of ccw that rotates the Pics by one rotunit + -- more every Pic, counterclockwise. +ccw :: Behaviour +ccw = [twist_Pic x | x <- [0.0,rotunit..]] + + -- same as ccw, but rotates the Pics clockwise +cw :: Behaviour +cw = [twist_Pic x | x <- [0.0,-rotunit..]] + + -- moves the Pic up by one more unit every Pic. +up :: Behaviour +up = [mov_Pic (x,y) | (x,y)<- zip2 [0,0..] [0,unit..]] + + -- moves the Pic down by one more unit every Pic. +down :: Behaviour +down = [mov_Pic (x,y) | (x,y)<-zip2 [0,0..] [0,-unit]] + + -- moves the Pic left by one more unit every Pic. +left :: Behaviour +left = [mov_Pic (x,y) | (x,y)<- zip2 [0,-unit..] [0,0..]] + + -- moves the Pic right by one more unit every Pic. +right :: Behaviour +right = [mov_Pic (x,y) | (x,y)<- zip2 [0,unit..] [0,0..]] + + diff --git a/progs/demo/X11/animation/r_defaults.hu b/progs/demo/X11/animation/r_defaults.hu new file mode 100644 index 0000000..f945bbc --- /dev/null +++ b/progs/demo/X11/animation/r_defaults.hu @@ -0,0 +1,3 @@ +:o= all +r_defaults.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_display.hs b/progs/demo/X11/animation/r_display.hs new file mode 100644 index 0000000..19f1d4a --- /dev/null +++ b/progs/demo/X11/animation/r_display.hs @@ -0,0 +1,114 @@ +module R_Display (displaym) where + +import R_Ptypes +import R_Utility +import Xlib +import R_Constants + +displaym :: String -> Int -> Movie -> IO () + +displaym host n movie = + let + movie' = cycle (take n (map (map translatePoly) movie)) + in + xOpenDisplay host + `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_color = xScreenBlackPixel screen + bg_color = xScreenWhitePixel screen + color_map = xScreenDefaultColormap screen + getPixels [] = returnIO [] + getPixels (c:cs) = + xLookupColor color_map c `thenIO` \ (xc, _) -> + xAllocColor color_map xc `thenIO` \ (p,_,_) -> + getPixels cs `thenIO` \ ps -> + returnIO (p:ps) + in + getPixels (map colorName allColors) + `thenIO` \ pixels -> + let + lookupPixel c = lookupPixel1 c allColors pixels + + lookupPixel1 x [] _ = head pixels + lookupPixel1 x (c:cs) (p:ps) = + if x == c then p + else lookupPixel1 x cs ps + parent = xScreenRoot screen + in + xMArrayCreate [lookupPixel i | i <- [0..15]] + `thenIO` \ pixelArray -> + xCreateGcontext (XDrawWindow parent) + [XGCBackground bg_color, + XGCForeground fg_color] + `thenIO` \ gcontext -> + xCreateGcontext (XDrawWindow parent) + [XGCBackground bg_color, + XGCForeground bg_color] + `thenIO` \ blank_gcontext -> + xCreateWindow parent + (XRect 100 100 500 500) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XButtonPress])] + `thenIO` \window -> + let depth = xDrawableDepth (XDrawWindow window) + in + xCreatePixmap (XSize 500 500) depth (XDrawWindow parent) + `thenIO` \ pixmap -> + xMapWindow window + `thenIO` \() -> + let + dispFrame m = + xDrawRectangle (XDrawPixmap pixmap) + blank_gcontext + (XRect 0 0 500 500) + True + `thenIO_` + dispPic m + `thenIO_` + xCopyArea (XDrawPixmap pixmap) gcontext (XRect 0 0 500 500) + (XDrawWindow window) (XPoint 0 0) + `thenIO_` + xDisplayForceOutput display + + dispPic [] = returnIO () + dispPic (p:ps) = dispPoly p `thenIO_` dispPic ps + + dispPoly (c, vec) = +-- xLookupColor color_map (colorName c) `thenIO` \ ec -> +-- xAllocColor color_map ec `thenIO` \ p -> + xMArrayLookup pixelArray c `thenIO` \p -> + xUpdateGcontext gcontext [XGCForeground p] `thenIO` \ () -> +-- xSetGcontextForeground gcontext (lookupPixel c) `thenIO` \ () -> + xDrawLines (XDrawPixmap pixmap) gcontext vec True + + untilButton3 (frame:frames) = + let + action = dispFrame frame `thenIO_` untilButton3 frames + in + xEventListen display `thenIO` \count -> + if count == 0 then action else + xGetEvent display `thenIO` \event -> + case (xEventType event) of + XButtonPressEvent -> + case (xEventCode event) of + 3 -> returnIO () + _ -> action + _ -> action + in + printString ("Click right button to end.\n") `thenIO_` + untilButton3 movie' `thenIO_` + xFreePixmap pixmap `thenIO_` + xCloseDisplay display + +type Movie' = [Pic'] +type Pic' = [Poly'] +type Poly' = (Int, [XPoint]) + +translatePoly :: Poly -> Poly' +translatePoly (c, vs) = (c, flatten_2 vs) + +flatten_2 [] = [] +flatten_2 ((a,b):r) = (XPoint (a `div` 2) (b `div` 2)):(flatten_2 r) + +printString :: String -> IO () +printString s = appendChan "stdout" s abort (returnIO ()) diff --git a/progs/demo/X11/animation/r_display.hu b/progs/demo/X11/animation/r_display.hu new file mode 100644 index 0000000..23f2c77 --- /dev/null +++ b/progs/demo/X11/animation/r_display.hu @@ -0,0 +1,6 @@ +:o= foldr inline constant +r_constants.hu +r_utility.hu +r_ptypes.hu +r_display.hs +$HASKELL_LIBRARY/X11/xlib.hu diff --git a/progs/demo/X11/animation/r_inbetween.hs b/progs/demo/X11/animation/r_inbetween.hs new file mode 100644 index 0000000..a7fb7d3 --- /dev/null +++ b/progs/demo/X11/animation/r_inbetween.hs @@ -0,0 +1,82 @@ +{-****************************************************************** + MODULE R_INBETWEEN + + This module takes care of interpolation functions. Basically, + given two Pics, inbetween will give you a movie gradually + converting from one Pic to the other Pic, using linear interpolation. + Tween will take two Movies, and append them, interpolating n + frames between the last Pic of the first Movie and the first Pic of + the last Movie. + +******************************************************************-} + +module R_Inbetween (inbetween,tween) where + +import R_Ptypes +import R_Utility +import R_Picture +import R_Behaviour + + -- inbetween takes an int and two Pics, and interpolates n Pics + -- of interpolated Pics. +inbetween :: Int -> Pic -> Pic -> Movie +inbetween n p1 p2 | (length p1 == length p2) = + ((zip1.(map (inbetweenp n))).zip1) [p1,p2] +inbetween n p1 p2 = inbetween n [(col,p1')] [(col,p2')] + where p1' = concat [ vs | (c,vs) <- p1] + p2' = concat [ vs | (c,vs) <- p2] + col = head [ c | (c,vs) <- p1 ] + + -- inbetweenp takes a list of 2 Polygons ([[Vec]]) and returns a + -- sequence of interpolated Polygons. Should the Number of vertices + -- of one Polygon be less than those in the other, it splits it so + -- as to have two Polygons of the same length. +inbetweenp :: Int -> Pic -> Pic +inbetweenp n [(c1,vs),(c2,ws)] = + if ((length vs) < (length ws)) then + inbetween1 (split (length ws) (c1,vs)) (c2,ws) 0 n + else if ((length vs) > (length ws)) then + inbetween1 (c1,vs) (split (length vs) (c2,ws)) 0 n + else inbetween1 (c1,vs) (c2,ws) 0 n + + + -- inbetween1 returns a sequence of interpolated Polygons. +inbetween1 :: Poly -> Poly -> Int -> Int -> Pic +inbetween1 p1 p2 m n | m>n || n<=0 = [] +inbetween1 p1 p2 m n = inbetween2 p1 p2 m n + :inbetween1 p1 p2 (m+1) n + + -- inbetween2 returns ONE of the required sequence of + -- interpolated Polygons. +inbetween2 :: Poly -> Poly -> Int -> Int -> Poly +inbetween2 (c1,vs) (c2,ws) p q = (c1, map (partway p q) (zip1 [vs,ws])) + + -- split splits up a Polygon so as to have the given #vertices. +split :: Int -> Poly -> Poly +split n (c,vs) = (c, split' n vs) + +split' :: Int -> [Vec] -> [Vec] +split' n vs | n<= (length vs) = vs +split' n vs = if (n>double) then + split' n (split' double vs) + else + v1:(mid v1 v2):(split' (n-2) (v2:vss)) + where double = 2*((length vs)) - 1 + (v1:v2:vss) = vs + + + -- tween will interpolate n Pics transforming the last Pic of + -- the first Movie into the first Pic of the second Movie, and + -- then run the second Movie +tween :: Int -> Movie -> Movie -> Movie +tween n m1 [] = m1 +tween n m1 m2 = m1 ++ (inbetween n (last m1) (head m2')) ++ (tail m2') + where m2' = apply (mov (repeat v)) m2 + v = vmin (orig_Pic (last m1)) (orig_Pic (head m2)) + + -- tweens will take a list of Movies and append them all, interpolating + -- n frames between every Movie. +tweens :: Int -> [Movie] -> Movie +tweens n = foldr (tween n) [] + + diff --git a/progs/demo/X11/animation/r_inbetween.hu b/progs/demo/X11/animation/r_inbetween.hu new file mode 100644 index 0000000..52771d0 --- /dev/null +++ b/progs/demo/X11/animation/r_inbetween.hu @@ -0,0 +1,3 @@ +:o= all +r_inbetween.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_movie.hs b/progs/demo/X11/animation/r_movie.hs new file mode 100644 index 0000000..a97a452 --- /dev/null +++ b/progs/demo/X11/animation/r_movie.hs @@ -0,0 +1,114 @@ +{-********************************************************************* + MODULE R_MOVIE + + This module contains necessary functions for editing Movies. There + are several that give information on a Movie, such as the heights or + wirdths of its Pics. The others all deal with the various ways of + combining various Movies into one Movie, a vital set of functions. + +*********************************************************************-} + +module R_Movie (ht, wid, orig, + above, rABOVE, beside, rBESIDE,rBESIDE2, over, rOVER, + overlay, rOVERLAY, pUT, + uncurry, curry + ) where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture + + -- takes a function and a list and returns a new list of element operated + -- on by the function. +promote:: (a->b)->[a]->[b] +promote f [] = [] +promote f [p] = f p:promote f [p] +promote f (p:ps) = f p:promote f ps + + -- promote1 takes a function that analyzes a Pic, and then applies it + -- to analyse a movie, returning a list. +promote1:: (Pic->a) -> Movie -> [a] +promote1 f ps = [f p | p <- ps] + + -- ht takes a Movie and returns a list of the heights of the Pics +ht :: Movie -> [Int] +ht = promote1 ht_Pic + + -- wid takes a Movie and returns a list of the widths of the Pics +wid :: Movie -> [Int] +wid = promote1 wid_Pic + + -- orig takes a Movie and returns a list of vectors that are the + -- origins of the Pics +orig:: Movie -> [Vec] +orig = promote1 orig_Pic + + -- promote2 takes a function accepting an element and a Pic, and + -- applies the function to the Movie and list, producing a new Movie +promote2:: (a->Pic->Pic) -> [a] -> Movie -> Movie +promote2 f ps qs = [f p q | (p,q) <- zip2 ps qs] + + -- takes two Movies and puts them above one another +above:: Movie -> Movie -> Movie +above = promote2 above_Pic + + -- takes a list of Movies and puts them all above one another +rABOVE:: [Movie] -> Movie +rABOVE = reduce above + + -- takes two Movies and puts them beside one another +beside:: Movie -> Movie -> Movie +beside = promote2 beside_Pic + + -- takes a list of Movies and puts them all beside one another +rBESIDE:: [Movie] -> Movie +rBESIDE = reduce beside + + -- same as beside, but with absolute coordinates. +beside2:: Movie -> Movie -> Movie +beside2 = promote2 beside2_Pic + + -- same as rBESIDE, but with absolute coordinates. +rBESIDE2:: [Movie] -> Movie +rBESIDE2 = reduce beside2 + + -- puts one Movie on top of the other Movie +over:: Movie -> Movie -> Movie +over = promote2 over_Pic + + -- takes a list of Movies, and puts the n-th on top of the first + -- through 9n-1)th. +rOVER:: [Movie] -> Movie +rOVER = reduce over + + -- just overlays the two Movies by appending the Pics. +overlay:: Movie -> Movie -> Movie +overlay = promote2 overlay_Pic + + -- overlays a list of Movies by appending the Pics +rOVERLAY:: [Movie] -> Movie +rOVERLAY = reduce overlay + + -- promote3 takes a function that takes two items and a Pic and + -- returns a Pic, and then applies it to two input lists and a Movie, + -- producing a new Movie. +promote3:: (a->b->Pic->Pic) -> [a] -> [b] -> Movie -> Movie +promote3 f ps qs rs = [f p q r | (p,q,r) <- zip3 ps qs rs] + + -- pUT takes a list of Vectors, and puts each Pic of the first Movie + -- in the location of the corresponding vector, on top of the Pic of + -- the second Movie, and returns that list as a new Movie. +pUT:: [Vec] -> Movie -> Movie -> Movie +pUT = promote3 put_Pic + + -- uncurry takes a function that takes two elements and a list of + -- two elements and applies the function to them. +uncurry:: (a->a->b) -> [a] -> b +uncurry f [a,b] = f a b + + -- curry takes a function that takes a list, and two elements, and + -- then applies the function to the elements in a list. +curry:: ([a]->b) -> a -> a -> b +curry f a b = f [a,b] + diff --git a/progs/demo/X11/animation/r_movie.hu b/progs/demo/X11/animation/r_movie.hu new file mode 100644 index 0000000..0023a04 --- /dev/null +++ b/progs/demo/X11/animation/r_movie.hu @@ -0,0 +1,3 @@ +:o= all +r_movie.hs +r_picture.hu diff --git a/progs/demo/X11/animation/r_picture.hs b/progs/demo/X11/animation/r_picture.hs new file mode 100644 index 0000000..ed3a50f --- /dev/null +++ b/progs/demo/X11/animation/r_picture.hs @@ -0,0 +1,188 @@ +{-************************************************************ + MODULE R_PICTURE + + This module contains all the functions that can be used to manipulate + Pic's. The user will probably never use any of these functions. They + are used by Behaviours and such higher-order functions, which apply + these routines to all the Pic's in the list. + +*************************************************************-} + +module R_Picture (close_Pic, ht_Pic, wid_Pic, orig_Pic, + overlay_Pic, put_Pic, over_Pic, above_Pic, beside_Pic, + map_Pic,beside2_Pic, + scale_Pic, scale_rel_Pic, mov_Pic, rot_Pic, twist_Pic, + twist_Pic', flipx_Pic, flipy_Pic, flip_Pic, {- flock_Pic, -} + set_Color_Pic, + to_orig_Pic, + movto_Pic + ) where + +import R_Ptypes +import R_Constants +import R_Utility + + -- close_Pic makes sure that the polygon is closed +close_Pic:: Pic -> Pic +close_Pic p = map close_Poly p + where + close_Poly (c,ply) | (head ply) == (last ply) = (c,ply) + close_Poly (c,ply) = (c,ply++(tail (reverse ply))) + + --these functions find the max and min x and y coordinates of a Pic +maxx :: Pic -> Int +maxx p = reduce max [x | (c,q) <- p, (x,y) <- q] + +minx :: Pic -> Int +minx p = reduce min [x | (c,q) <- p, (x,y) <- q] + +maxy :: Pic -> Int +maxy p = reduce max [y | (c,q) <- p, (x,y) <- q] + +miny :: Pic -> Int +miny p = reduce min [y | (c,q) <- p, (x,y) <- q] + + -- these functions find the height, width and origin of a Pic +ht_Pic :: Pic -> Int +ht_Pic p = (maxy p) - (miny p) + +wid_Pic :: Pic -> Int +wid_Pic p = (maxx p) - (minx p) + +orig_Pic:: Pic -> Vec +orig_Pic p = ( (maxx p + minx p) `div` 2, (maxy p + miny p) `div` 2 ) + +-- PICTURE COMBINING OPERATIONS: + + -- overlay_Pic just takes 2 Pics and puts them together into one +overlay_Pic:: Pic -> Pic -> Pic +overlay_Pic p q = p ++ q + + -- put_Pic overlays the Pics, offsetting the first Pic by a vector + -- amount from the origin of the second +put_Pic:: Vec -> Pic -> Pic -> Pic +put_Pic v p q = overlay_Pic + (movto_Pic (vplus (orig_Pic q) v) p ) + q + + -- over_Pic puts one Pic directly on top of the other +over_Pic:: Pic -> Pic -> Pic +over_Pic p q = put_Pic (0,0) p q + + -- above_Pic puts the first Pic on top of the second +above_Pic:: Pic -> Pic -> Pic +above_Pic p q = put_Pic (0,(((ht_Pic q) + (ht_Pic p)) `div` 2)) p q + + -- beside_Pic puts the first Pic beside the second. The width of + -- the Pic is defined as the max x minus the min x, so a moving + -- figure will stand still in this implementation +beside_Pic:: Pic -> Pic -> Pic +beside_Pic p q = put_Pic (((wid_Pic q)+(wid_Pic p)) `div` 2, 0) p q + + -- beside2_Pic puts the first Pic beside the second, without + -- shifting to the width of the Pic. It uses the absolute coordinates. +beside2_Pic:: Pic -> Pic -> Pic +beside2_Pic p q = put ((wid_Pic q), 0) p q + where put v p q = overlay_Pic (mov_Pic v p) q + + + -- The following maps a given function over the Vector-list of each Polygon: +map_Pic:: (Vec -> Vec) -> Pic -> Pic +map_Pic f p = map f' p + where f' (c,vs) = (c, map f vs) + +-- THE GEOMETRIC TRANSFORMATIONS: + + -- scales the Pic by r, where r is in units of 11th. ie r=1, the Pic is + -- scaled by 1/11 to its origin. +scale_Pic :: Int -> Pic -> Pic +scale_Pic r p + = map_Pic (scalep r) p + where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11) + dx = fst (orig_Pic p) + dy = snd (orig_Pic p) + + -- this is another scaling function, but it centers the image at the Vec +scale_rel_Pic :: Vec -> Int -> Pic -> Pic +scale_rel_Pic v r + = map_Pic (scalep r) + where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11) + dx = fst v + dy = snd v + + -- moves a Pic by the vector amount +mov_Pic:: Vec -> Pic -> Pic +mov_Pic v = map_Pic (vplus v) + + -- moves a Pic to the vector +movto_Pic:: Vec -> Pic -> Pic +movto_Pic v p = mov_Pic (vmin v (orig_Pic p)) p + + -- moves the origin of the Pic to the lower left side of the Pic +to_orig_Pic:: Pic -> Pic +to_orig_Pic p = mov_Pic (-mx,-my) p + where mx = minx p + my = miny p + + -- rotates the Pic about the Vector by theta +rot_Pic :: Vec -> Float -> Pic -> Pic +rot_Pic (a,b) theta + = map_Pic (rotp (a,b) theta) + where rotp (a,b) t (v1,v2) + = vftov (a2+ (u * cos theta - v * sin theta), + b2+ (u * sin theta + v * cos theta)) + where u = u1 -a2 + v = u2 -b2 + (u1,u2) = vtovf (v1,v2) + (a2,b2) = vtovf (a,b) + + -- rotates a Pic about its origin by theta +twist_Pic :: Float -> Pic -> Pic +twist_Pic theta p = rot_Pic (orig_Pic p) theta p + + + -- hardwired version of rot_Pic that runs faster by rotating a set + -- unit, the rotunit, every time +rot_Pic':: Vec -> Pic -> Pic +rot_Pic' (a,b) = map_Pic (rotp (a,b)) + where rotp (a,b) (v1,v2) + = vftov (a2+ (u * cosunit - v * sinunit), + b2+ (u * sinunit + v * cosunit)) + where u = u1-a2 + v = u2-b2 + (u1,u2) = vtovf (v1,v2) + (a2,b2) = vtovf (a,b) + + -- hardwired version of twist_Pic that runs faster using rot_Pic' +twist_Pic':: Pic -> Pic +twist_Pic' p = rot_Pic' (orig_Pic p) p + + -- flips the Pic about the line x=n (x-coordinates change) +flipx_Pic :: Int -> Pic -> Pic +flipx_Pic n = map_Pic (flipvx n) + where + flipvx n (a,b) = (2*(n-a)+a,b) + + -- flips the Pic about the line y=n (y-coordinates change) +flipy_Pic :: Int -> Pic -> Pic +flipy_Pic n = map_Pic (flipvy n) + where + flipvy n (a,b) = (a, 2*(n-b)+b) + + -- flips the Pic about its own x origin. +flip_Pic:: Pic -> Pic +flip_Pic p = map_Pic (flipvx x) p + where (x,y) = orig_Pic p + flipvx n (a,b) = (2*(n-a)+a,b) + + -- copies the Pic into another Pic n*n times in an n by n array pattern +flock_Pic :: Int -> Pic -> Pic +flock_Pic 1 p = p +flock_Pic (n+2) p = beside_Pic (flock_Pic (n-1) p) (row n p) + where row n p = replicate n above_Pic nullpic p + + -- changes the color of the Pic +set_Color_Pic:: Color -> Pic -> Pic +set_Color_Pic c p = map f p + where f (c',vs) = (c,vs) + diff --git a/progs/demo/X11/animation/r_picture.hu b/progs/demo/X11/animation/r_picture.hu new file mode 100644 index 0000000..932d87c --- /dev/null +++ b/progs/demo/X11/animation/r_picture.hu @@ -0,0 +1,4 @@ +:o= all +r_picture.hs +r_constants.hu +r_utility.hu diff --git a/progs/demo/X11/animation/r_ptypes.hs b/progs/demo/X11/animation/r_ptypes.hs new file mode 100644 index 0000000..c020f82 --- /dev/null +++ b/progs/demo/X11/animation/r_ptypes.hs @@ -0,0 +1,67 @@ +{-*********************************************************************** + MODULE PTYPES + + This module contains the definitions for all the basic datatypes used to + create functional movies. + The basis of all the images is the Poly, which is a tuple of a color + and a list of points. This is displayed as a polygon of that color. The + form is a line drawn to each of the points, in order. + A list of these Poly's is a Pic, or picture. Each picture is a single + frame of the movie. A list of Pic's makes up a Movie, which is a series + of Pic's displayed in order. + Behaviours affect the movies, such as moving them left, or right. + PictoPic's affect a single picture. + The other functions simply convert regular values such as integers + and floats to the datatypes used by the functional programming. + +************************************************************************-} + + +module R_Ptypes (Vec(..), Color(..), Pic(..), Poly(..), Movie(..), Behaviour(..), PictoPic(..), Process(..), + Vecfloat(..), + Msg(..), Chan(..), + Val (..), + ntov, vtov, nstov, vstov, pstov, bstov + ) where + + + --These are the basic data types for storing and manipulating the movies. + +type Vec = (Int,Int) +type Color = Int +type Pic = [Poly] +type Poly = (Color,[Vec]) +type Movie = [Pic] +type Behaviour = [Pic -> Pic] +type PictoPic = Pic -> Pic + +type Process = [Msg] -> [Msg] +type Msg = [(Chan,Val)] +type Chan = [Char] + +data Val = N Int | V (Int,Int) | P Pic | B PictoPic + +type Vecfloat = (Float,Float) + + + +--Those convert from the various regular values to Val's. + +ntov n = N n + +vtov:: Vec -> Val +vtov v = V v + +ptov:: Pic -> Val +ptov p = P p + +nstov ns = [N n|n<-ns] + +vstov:: [Vec] -> [Val] +vstov vs = [V v|v<-vs] + +pstov:: [Pic] -> [Val] +pstov ps = [P p|p<-ps] + +bstov:: [PictoPic] -> [Val] +bstov bs = [B b|b<-bs] diff --git a/progs/demo/X11/animation/r_ptypes.hu b/progs/demo/X11/animation/r_ptypes.hu new file mode 100644 index 0000000..8a99f8f --- /dev/null +++ b/progs/demo/X11/animation/r_ptypes.hu @@ -0,0 +1,2 @@ +:o= all +r_ptypes.hs diff --git a/progs/demo/X11/animation/r_shapes.hs b/progs/demo/X11/animation/r_shapes.hs new file mode 100644 index 0000000..aef3362 --- /dev/null +++ b/progs/demo/X11/animation/r_shapes.hs @@ -0,0 +1,38 @@ +{-***************************************************************** + MODULE R_SHAPES + + This modules produces Pic's of boxes and triangles to help build + Pic's to animate. + +******************************************************************-} + +module R_Shapes (box, tri, circ_mov, circ) where + +import R_Ptypes +import R_Utility +import R_Picture +import R_Behaviour + + -- box takes four three ints, the color, width and height of the box and + -- returns a Pic of a box +box :: Int -> Int -> Int -> Pic +box c width height= [(c,[(0,0),(width,0),(width,height),(0,height),(0,0)])] + + -- tri takes a color and three vectors, and returns a Pic of a triangle + -- with the vectors as vertices +tri:: Color -> Vec -> Vec -> Vec -> Pic +tri c (x1,y1) (x2,y2) (x3,y3) = [(c,[(x1,y1),(x2,y2),(x3,y3),(x1,y1)])] + + + -- circ takes a color, the radius +circ :: Color -> Int -> Int -> Pic +circ c r inc = [(c,(r+r,r):(circ' r' inc' 1.0))] + where r' = (fromIntegral r) + inc' = (fromIntegral inc) + +circ' :: Float -> Float -> Float -> [Vec] +circ' r inc c | c>inc = [] +circ' r inc c = vftov (x+r,y+r) : (circ' r inc (c+1.0)) + where x = r*(cos((2*c*pi)/inc)) + y = r*(sin((2*c*pi)/inc)) + diff --git a/progs/demo/X11/animation/r_shapes.hu b/progs/demo/X11/animation/r_shapes.hu new file mode 100644 index 0000000..ad0bf40 --- /dev/null +++ b/progs/demo/X11/animation/r_shapes.hu @@ -0,0 +1,3 @@ +:o= all +r_shapes.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_utility.hs b/progs/demo/X11/animation/r_utility.hs new file mode 100644 index 0000000..9dfcc65 --- /dev/null +++ b/progs/demo/X11/animation/r_utility.hs @@ -0,0 +1,150 @@ +{-********************************************************************* + MODULE R_UTILITY + + This module contains all the basic utility functions that the other + modules need to have to write their code. These are made generally + low level functions, manipulating vectors or defining very + general functions + +**********************************************************************-} + + +module R_Utility (vtovf,vftov, + vplus, vmin, mid, partway, + mag, + reduce, power, i, + member, repeat, zip1, zip2, zip3, rept, replicate, + mapc, + append, flatten, rptseq, osc + ) where + +import R_Ptypes + + +-- CONVERSION + + -- vtovf takes a vector of integers, and converts it to a vector of floats +vtovf :: Vec -> Vecfloat +vtovf (x,y) = (fromIntegral x,fromIntegral y) + + -- vftov takes a vector of floats and converts it to a vector of integers. + -- It rounds the floats off to do this. +vftov :: Vecfloat -> Vec +vftov (x,y) = (round x,round y) + + +-- VECTOR OPERATIONS: + + -- vector addition +vplus:: Vec -> Vec -> Vec +vplus (a,b) (c,d) = (a+c,b+d) + + -- vector substraction +vmin:: Vec -> Vec -> Vec +vmin (a,b) (c,d) = (a-c,b-d) + + -- finds the midpoint between two vectors +mid:: Vec -> Vec -> Vec +mid (x1,y1) (x2,y2) = (div (x1+x2) 2,div (y1+y2) 2 ) + + -- finds a point p/q along the way between two vectors +partway :: Int -> Int -> [Vec] -> Vec +partway p q [(x1,y1),(x2,y2)] + = vplus (x1,y1) ( div (p*(x2-x1)) q, div (p*(y2-y1)) q ) + + -- finds the magnitude of two vectors +mag :: Vec -> Int +mag p = round (magfloat (vtovf p)) + +magfloat :: Vecfloat -> Float +magfloat (x,y) = sqrt (x*x + y*y) + + -- returns a vector at right angles to the input vector +normal:: Vec -> Vec +normal (x,y) = (-y,x) + + -- returns the first vector projected onto the second +project:: Vec -> Vec -> Vec +project (vx,vy) (wx,wy) = partway (vx*wx+vy*wy) (mw*mw) [(0,0),(wx,wy)] + where mw = mag (wx,wy) + + +-- HIGHER-ORDER FUNCTIONS: + + -- just foldr1. It applies a function of two inputs to an entire list + -- recursively, and displays the single element result +reduce :: (a->a->a) -> [a] -> a +reduce = foldr1 + + -- power applies a single function n times to a seed +power :: Int -> (a->a) -> a -> a +power 0 f seed = seed +power (n+1) f seed = f (power n f seed) + + -- i takes an element and returns an infinite list of them +i :: a -> [a] +i x = x: (i x) + + -- checks to see if x is in the list of xs +member :: (Eq a) => [a] -> a -> Bool +member [] x = False +member (y:ys) x = x == y || member ys x + + -- zip1 takes lists of lists, and rearranges them so that all the first + -- elements are in the first list, all the second in the second and so on. +zip1 :: (Eq a) => [[a]] -> [[a]] +zip1 xs | member xs [] = [] +zip1 xs = (map head xs):(zip1 (map tail xs)) + + -- takes two lists and makes a list of tuples. +zip2 :: [a] -> [b] -> [(a,b)] +zip2=zip + + -- rept takes a function and a list of elements, and applies the function + -- n-1 times to the n-th element +rept :: (a->a) -> a -> [a] +rept f x = x:(rept f (f x)) + + -- replicate creates an list n elements long of a, with the function + -- applies to the n-th element n-1 times. +replicate :: Int -> (a->a->a) -> a -> a -> a +replicate 0 f zero a = zero +replicate 1 f zero a = a +replicate (n+2) f zero a = f a (replicate (n+1) f zero a) + + -- mapc is a map function for lists of functions (behaviours) +mapc :: (a->b) -> [c->a] -> [c->b] +mapc f as = [f.a | a <- as] + + +-- FUNCTIONS OVER SEQUENCES: + + -- append takes a list of lists, and makes them into one giant happy list. +append :: [[a]] -> [a] +append = foldr (++) [] + + -- flatten takes a list of lists of tuples and gives one giant happy list + -- of single elements back. +flatten:: [[(a,a)]] -> [a] +flatten s = foldr f [] (append s) + where f (x,y) [] = [x,y] + f (x,y) (z:zs) = x:y:(z:zs) + + -- rptseq takes a list of elements and applies a function to them, + -- n-1 times for the n-th element, but using map +rptseq :: (a->a) -> [a] -> [a] +rptseq f [] = [] +rptseq f (x:xs) = x:rptseq f (map f xs) + + -- osc takes a list, and makes sure it oscillates. If the head is + -- equal to the tail, it simply repeats the sequence infinitely. If + -- the head is not equal to the tail, it adds the sequence then adds + -- the reversed sequence minus the first and last elements, and then repeats +osc :: [a] -> [a] +osc s | (length s) == 0 = [] +osc s | (length s) == 1 = head s: osc s +osc s = (s ++ (((tail.reverse).tail) s)) ++ (osc s) + + + + diff --git a/progs/demo/X11/animation/r_utility.hu b/progs/demo/X11/animation/r_utility.hu new file mode 100644 index 0000000..6fac189 --- /dev/null +++ b/progs/demo/X11/animation/r_utility.hu @@ -0,0 +1,3 @@ +:o= all +r_utility.hs +r_ptypes.hu diff --git a/progs/demo/X11/animation/seafigs.hs b/progs/demo/X11/animation/seafigs.hs new file mode 100644 index 0000000..c216a63 --- /dev/null +++ b/progs/demo/X11/animation/seafigs.hs @@ -0,0 +1,158 @@ +module Seafigs (sky,blue_sky,clouds,clouds2,gull,man,sun,vm,windmill,palm) where + +import Animation + +blue_sky:: Movie +blue_sky = osc [box lightblue 1000 1000] + +sky:: Color -> Movie +sky c = osc [box c 1000 1000] + +clouds2:: Movie +clouds2 = apply (mov (i (cld_wid,0))) (rBESIDE[cld,cld]) + where cld_wid = -(wid_Pic (cld!!0)) + cld= apply (bPar [right,mov (repeat (250,-50))]) cldm1 + cldm1=osc[cloud1] + +clouds:: Movie +clouds + = rOVERLAY + [apply (bPar [right,mov (repeat (250,-50))]) cloudm1, + apply (bPar [right,mov (repeat (0,-50))]) cloudm2, + apply (bPar [right,mov (repeat (250,-75))]) cloudm2, + apply (bPar [right,flipb,smaller,mov(repeat (200,-100))]) cloudm2, + apply (bPar [right,flipb,smaller,mov(repeat (300,-125))]) cloudm1, + apply (bPar [right,right,mov (repeat (-50,50))]) cloudm1] + where cloudm1 = osc [cloud1] + cloudm2 = osc [cloud2] + + +cloud1 = [(white,ply)] + where ply = [(142,301),(169,309),(180,315),(192,312), + (196,308),(202,302),(216,300),(224,308), + (238,312),(258,311),(274,301),(278,283), + (265,279),(246,279),(230,281),(197,286), + (185,288),(167,287),(148,287),(136,292), + (136,292),(142,301)] + + +cloud2 = [(white,ply)] + where ply = [(51,262), (56,266), + (66,265), (90,264), (92,266), (98,270), + (111,268),(137,268),(155,266),(174,266), + (183,262),(183,253),(162,251),(136,254), + (132,250),(126,248),(115,252),(109,253), + (98,252), (90,253), (88,254), (67,254), + (56,252), (49,254), (47,259), (51,262)] + +gull :: Movie +gull = osc [gull1,gull2] + +gull1 = [(black,[(2,4),(6,4),(9,2),(10,0),(11,2), + (16,4),(20,4)])] + +gull2 = [(black,[(0,0),(2,2),(6,3),(9,2),(12,3), + (16,2),(18,0)])] + +man :: Movie +man = osc [man1,man2,man3] + + +man1 = [(black,[(0,0),(10,0),(20,40),(30,60),(40,20), + (60,0),(50,0)]), + (black,[(0,40),(20,60),(30,80),(50,70),(60,60)]), + (black,[(30,60),(30,100)]), + (black,[(30,100),(25,100),(20,105),(23,112), + (20,115),(30,120),(35,120),(40,115), + (40,110),(35,105),(30,100)]) + ] + +man2 = [(black,[(20,0),(30,0),(20,40),(30,60),(45,30), + (60,20),(50,0)]), + (black,[(0,60),(20,60),(20,80),(40,80),(50,60)]), + (black,[(30,60),(20,100)]), + (black,[(20,100),(15,100),(10,105),(13,112), + (10,115),(20,120),(30,120),(30,115), + (30,110),(25,105),(20,100)]) + ] + +man3 = [(black,[(0,15),(5,10),(15,45),(30,60),(35,25), + (44,10),(35,0)]), + (black,[(10,40),(22,60),(20,80),(40,75),(45,44)]), + (black,[(30,60),(20,100)]), + (black,[(20,100),(19,100),(14,105),(17,112), + (14,115),(24,120),(34,120),(34,115), + (34,110),(29,105),(200,100)]) + ] + +sun :: Movie +sun = osc [sun'] + where + sun' = reduce overlay_Pic [sun1, + twist_Pic (pi/24.0) sun1, + twist_Pic (pi/12.0) sun1] + +sun1 = [(yellow,[(43,16),(18,27),(9,51),(20,71),(42,81), + (66,73),(76,47),(69,25),(43,15),(43,16)])] + +vm :: Movie +vm = osc[vm1,vm2] + +vm1 = beside_Pic (box brown 10 15) + (above_Pic light1 (box brown 40 80)) + where light1 = box yellow 10 10 + +vm2 = beside_Pic (box brown 10 15) + (reduce above_Pic [light,light2,box brown 40 80]) + where light2 = over_Pic (box red 10 10) (box white 5 5) + light = [ (red,[(5,5), (10,2), (0,30),(5,5)]), + (red,[(20,2),(25,5),(30,30),(20,2)]), + (red,[(15,15),(20,15),(15,50),(10,25)])] + +windmill :: Movie +windmill + = apply + (bpar (mov (repeat (unit*3,0))) (scale_rel (0,0) (repeat 3))) + (overlay body (apply (movto (repeat (100,400))) prop)) + +blade = osc [tri red (0,0) (100,0) (50,300)] +prop = apply cw fan + +fan = rOVERLAY [fan1,fan2,fan3,fan4] +fan1 = blade +fan2 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan1 +fan3 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan2 +fan4 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan3 + +body = osc [ [(brown,[(0,0),(200,0),(170,300), + (100,400),(30,300),(0,0)]) ] ] + + +palm :: Movie +palm + = osc palms + where palms = inbetween 3 palm1 (flipx_Pic 100 palm1) + palm1 = reduce overlay_Pic [trunk,frond1,frond2,frond3,frond4] + where frond1 = [ (green,[(50,60),(60,70),(80,60)]), + (green,[(50,70),(60,80),(80,70)]), + (green,[(50,80),(55,90),(70,80)]), + (green,[(60,70),(55,90),(50,100)]) ] + + frond2 = flipx_Pic 50 frond1 + + frond3 = [ (green,[(10,70),(5,80)]), + (green,[(10,80),(10,90)]), + (green,[(20,90),(20,100)]), + (green,[(30,95),(40,104)]), + (green,[(5,80),(20,100),(40,104), + (50,100)])] + + frond4 = [(green,[(0,100),(5,110)]), + (green,[(15,105),(15,115)]), + (green,[(25,105),(30,115)]), + (green,[(35,105),(40,115)]), + (green,[(5,110),(30,115),(50,110), + (50,100)])] + + trunk = [(brown,[(100,0),(95,40),(80,80), + (70,90),(60,97),(50,100)])] diff --git a/progs/demo/X11/animation/seafigs.hu b/progs/demo/X11/animation/seafigs.hu new file mode 100644 index 0000000..83fcfcf --- /dev/null +++ b/progs/demo/X11/animation/seafigs.hu @@ -0,0 +1,3 @@ +:o= all +animation.hu +seafigs.hs diff --git a/progs/demo/X11/animation/seaside.hs b/progs/demo/X11/animation/seaside.hs new file mode 100644 index 0000000..fe11e12 --- /dev/null +++ b/progs/demo/X11/animation/seaside.hs @@ -0,0 +1,25 @@ +module Seaside (main) where + +import Animation +import Seafigs + +seaside :: Movie +seaside = rOVERLAY [blue_sky, + apply (bPar [up,cw,movto (repeat botm)]) sun, + apply right clouds, + apply (bPar [right,bigger]) gull, + apply (bPar [right,right,bigger]) gull, + apply (bPar [up,up,right,bigger]) gull, + apply (bPar [up,right,right,right]) gull, + windm, + apply (mov (repeat botm)) palm, + man_and_vm + ] + where man_and_vm = rBESIDE2 [manfig, vm] + manfig = apply left (apply (mov (i (700,0))) + man) + windm = apply (mov (i (500,0))) windmill + + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 (map (flipy_Pic 500) seaside)) diff --git a/progs/demo/X11/animation/seaside.hu b/progs/demo/X11/animation/seaside.hu new file mode 100644 index 0000000..df2c4b9 --- /dev/null +++ b/progs/demo/X11/animation/seaside.hu @@ -0,0 +1,5 @@ +:o= all +seaside.hs +seafigs.hu + + diff --git a/progs/demo/X11/draw/README b/progs/demo/X11/draw/README new file mode 100644 index 0000000..b844d2b --- /dev/null +++ b/progs/demo/X11/draw/README @@ -0,0 +1 @@ +This is the draw program used in the X window documentation diff --git a/progs/demo/X11/draw/draw.hs b/progs/demo/X11/draw/draw.hs new file mode 100644 index 0000000..1ba68ce --- /dev/null +++ b/progs/demo/X11/draw/draw.hs @@ -0,0 +1,41 @@ +module Draw where + +import Xlib + +main = getEnv "DISPLAY" exit (\ host -> draw host) + +draw :: String -> IO () +draw host = + xOpenDisplay host `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_color = xScreenBlackPixel screen + bg_color = xScreenWhitePixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 100 100 400 400) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XButtonMotion, + XButtonPress, + XKeyPress])] + `thenIO` \window -> + xMapWindow window `thenIO` \() -> + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ gcontext -> + let + handleEvent :: XPoint -> IO () + handleEvent last = + xGetEvent display `thenIO` \event -> + let pos = xEventPos event + in + case (xEventType event) of + XButtonPressEvent -> handleEvent pos + XMotionNotifyEvent -> + xDrawLine (XDrawWindow window) gcontext last pos `thenIO` \() -> + handleEvent pos + XKeyPressEvent -> xCloseDisplay display + _ -> handleEvent last + in + appendChan stdout "Press any key to quit.\n" exit done `thenIO` \ _ -> + handleEvent (XPoint 0 0) diff --git a/progs/demo/X11/draw/draw.hu b/progs/demo/X11/draw/draw.hu new file mode 100644 index 0000000..f09a72e --- /dev/null +++ b/progs/demo/X11/draw/draw.hu @@ -0,0 +1,2 @@ +$HASKELL_LIBRARY/X11/xlib.hu +draw.hs diff --git a/progs/demo/X11/gobang/README b/progs/demo/X11/gobang/README new file mode 100644 index 0000000..d5634a4 --- /dev/null +++ b/progs/demo/X11/gobang/README @@ -0,0 +1,66 @@ +gobang Weiming Wu & Niping Wu + + +Introduction + +Our final project is to design and implement a Gobang game under +X-Window3.2 environment, using the Haskell programming language. Users +can play the game human-vs-human. The program also provides a robot +player with whom the user can play the game with. We wrote altogether +ten modules which were saved in different files to control the whole +game. + + +About Gobang + +The checkerboard of Gobang consists of 19 vertical lines and 19 +horizontal lines. Two players in turn place a unit on the +checkerboard. Each unit should be put on an unoccupied intersection +of a vertical and a horizontal line. The winner is the player who +first makes five consecutive units on either vertical, horizontal or +diagonal direction. + +The program is able to perform the following tasks: 1) Use a new +window under X-Window interface to display the checkerboard. Players +will use a mouse to place units onto the chessboard, where a unit is a +circle with the color black or white. 2) Prompt for the names of both +players and display them. 3) Calculate the time both players have +used up. 4) Supervise the progress of the game, declare winner and +end the game once one player wins. 5) At each point of the game, +store the progress of the game, so players can review each step during +the game. 6) There are five buttons on the screen which would provide +some special services such as starting a new game, quitting the game, +saving the game, importing the saved game, or reviewing the game as +soon as the user selects the corresponding buttons. 7) Provide a +moderately well robot player for that game (using minimum-maximum +algorithm). + + +Running Gobang + +A window titled "gobang" will appear on the screen. On it is a +checkerboard, clocks and buttons. There will be an instruction saying +"Please enter the name of player-1". The user can do two things: +either enter the name of a player or choose the "import" button. Once +the "import" button is selected, an unfinished game, which was saved +in the file "###go.bhs###" will be imported. Please notice that the +character "@" is reserved for the robot player, so if the user types +in @ as the name of the first player, it is assumed that player-1 is +the robot player. Then the name of player 2 is prompted. The game +starts and at each turn an instruction like "Please enter your play." +would appear on the screen. The user should put a unit onto the +checkerboard. If the button is clicked on a wrong place or a unit is +put onto an occupied position, an error message saying "Wrong Point. +Please reenter." will appear on the screen and the user should reenter +his play. The marker next to the name of a player indicates whose +turn it is. At any point of the game the user can choose the other +four buttons. If the "new" button is selected, the present game will +be terminated and a new blank checkerboard will be displayed on the +screen; if the "review" button is selected, one step of the previous +plays will be displayed each time after the user hits any key; if the +"save" button is selected, the steps so far will be saved into the +file "###go.bhs###"; if the "quit" button is selected, the game will +be terminated. + + + diff --git a/progs/demo/X11/gobang/gobang.hs b/progs/demo/X11/gobang/gobang.hs new file mode 100644 index 0000000..f4844dc --- /dev/null +++ b/progs/demo/X11/gobang/gobang.hs @@ -0,0 +1,364 @@ +module Gobang where + +import Xlib +import Utilities +import Redraw +import Weights + +getXInfo :: String -> IO XInfo +getXInfo host = + xOpenDisplay host `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_pixel = xScreenBlackPixel screen + bg_pixel = xScreenWhitePixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 0 0 900 600) + [XWinBackground bg_pixel, + XWinEventMask (XEventMask [XButtonPress, + XKeyPress, + XExposure])] + `thenIO` \ window -> + xSetWmName window "Gobang" `thenIO` \() -> + xMapWindow window `thenIO` \() -> + xOpenFont display "10x20" `thenIO` \ playerfont -> + xOpenFont display "6x13" `thenIO` \ genericfont -> + xCreateGcontext (XDrawWindow window) + [XGCBackground bg_pixel, + XGCForeground fg_pixel] `thenIO` \ gcontext -> + xCreateGcontext (XDrawWindow window) + [XGCBackground fg_pixel, + XGCForeground bg_pixel, + XGCFont genericfont] `thenIO` \ gcontext2 -> + xCreateGcontext (XDrawWindow window) + [XGCBackground bg_pixel, + XGCForeground fg_pixel, + XGCFont playerfont] `thenIO` \ gcontextp -> + returnIO (XInfo display window gcontext gcontext2 gcontextp) + +demo = main + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError (\(XError msg) -> appendChan stdout msg exit done) $ + gobang host + +gobang :: String -> IO () +gobang host = + getXInfo host `thenIO` \ xinfo -> + xMArrayCreate [1..361] `thenIO` \ board -> + xMArrayCreate [1..361] `thenIO` \ weight1 -> + xMArrayCreate [1..361] `thenIO` \ weight2 -> + xMArrayCreate [1..722] `thenIO` \ steps -> + xMArrayCreate [""] `thenIO` \ player1 -> + xMArrayCreate [""] `thenIO` \ player2 -> + xMArrayCreate [1..4] `thenIO` \ time -> + xMArrayCreate [1] `thenIO` \ numbersteps -> + xMArrayCreate [""] `thenIO` \ promptString -> + xMArrayCreate [1] `thenIO` \ next_player -> + let state = GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player + in + initGame xinfo state `thenIO` \ _ -> + promptPlayers xinfo state `thenIO` \ _ -> + playGame xinfo state + +promptPlayers xinfo state = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + promptFor "player 1:" xinfo state `thenIO` \ player1_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name + `thenIO` \ _ -> + xMArrayUpdate player1 0 player1_name `thenIO` \ _ -> + promptFor "player 2:" xinfo state `thenIO` \ player2_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name + `thenIO` \ _ -> + xMArrayUpdate player2 0 player2_name `thenIO` \ _ -> + clearCmd xinfo state + +initGame :: XInfo -> GameState -> IO () +initGame xinfo + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = + getTime `thenIO` \ curtime -> + initArray time 0 2 0 `thenIO` \() -> + initArray time 2 4 curtime `thenIO` \() -> + initArray numbersteps 0 1 0 `thenIO` \() -> + initArray board 0 361 0 `thenIO` \() -> + initArray weight1 0 361 0 `thenIO` \() -> + initArray weight2 0 361 0 `thenIO` \ () -> + initArray next_player 0 1 1 `thenIO` \ () -> + clearCmd xinfo state `thenIO` \ () -> + redraw xinfo state + + +handleButton :: XPoint -> XInfo -> GameState -> GameCont -> IO () +handleButton (XPoint x y) + xinfo + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + cont + | buttonPress 700 330 x y = initArray player1 0 1 "" `thenIO` \ _ -> + initArray player2 0 1 "" `thenIO` \ _ -> + initGame xinfo state `thenIO` \ _ -> + promptPlayers xinfo state `thenIO` \ _ -> + playGame xinfo state + | buttonPress 700 360 x y = initGame xinfo state `thenIO` \ _ -> + playGame xinfo state + | buttonPress 700 390 x y = undoGame xinfo state cont + | buttonPress 700 420 x y = loadGame xinfo state cont + | buttonPress 700 450 x y = saveGame xinfo state `thenIO` \ () -> + cont xinfo state + | buttonPress 700 480 x y = quitGame xinfo state cont + | ishelp x y = helpGame xinfo state `thenIO` \ () -> + cont xinfo state + | otherwise = cont xinfo state + +when :: Bool -> IO () -> IO () +when cond action = if cond then action else returnIO () + +undoGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + cont = + xMArrayLookup next_player 0 `thenIO` \ next_p -> + xMArrayLookup player1 0 `thenIO` \ name1 -> + xMArrayLookup player2 0 `thenIO` \ name2 -> + let undoStep n = + xMArrayLookup steps (2*n) `thenIO` \ x -> + xMArrayLookup steps (2*n+1) `thenIO` \ y -> + xMArrayUpdate board ((x-1)*19 + y-1) 0 `thenIO` \ _ -> + (if (name1 == "computer" || name2 == "computer") + then draw_unit board weight1 weight2 x y + else returnIO ()) `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (x*30-15) (y*30-15) 30 30) True + `thenIO` \() -> +-- drawBoard xinfo `thenIO` \ _ -> +-- drawPieces 1 1 board xinfo `thenIO` \ _ -> + let x30 = x * 30 + y30 = y * 30 + c = XPoint x30 y30 + w = XPoint (x30-15) y30 + e = XPoint (x30+15) y30 + no = XPoint x30 (y30-15) + s = XPoint x30 (y30+15) + m = XArc (x30-3) (y30-3) 6 6 (-1.0) 6.283 + in + when (x > 1) (xDrawLine (XDrawWindow window) gcontext w c) + `thenIO` \ _ -> + when (x < 19) (xDrawLine (XDrawWindow window) gcontext c e) + `thenIO` \ _ -> + when (y > 1) (xDrawLine (XDrawWindow window) gcontext no c) + `thenIO` \ _ -> + when (y < 19) (xDrawLine (XDrawWindow window) gcontext c s) + `thenIO` \ _ -> + when ((x `elem` [4,10,16]) && (y `elem` [4,10,16])) + (xDrawArc (XDrawWindow window) gcontext m True) + `thenIO` \ _ -> + xDisplayForceOutput display `thenIO` \ _ -> + xMArrayUpdate numbersteps 0 n `thenIO` \ _ -> + xMArrayLookup next_player 0 `thenIO` \ next_p -> + xMArrayUpdate next_player 0 (if next_p == 1 then 2 else 1) + + cur_name = if next_p == 1 then name1 else name2 + last_name = if next_p == 1 then name2 else name1 + in + xMArrayLookup numbersteps 0 `thenIO` \ n -> + if n==0 then drawCmd "No more steps to undo!" xinfo state `thenIO` \ _ -> + cont xinfo state + else + if cur_name == "computer" then cont xinfo state + else + (undoStep (n-1) `thenIO` \_ -> + if (last_name == "computer" && n /= 1) then undoStep (n-2) + else + returnIO ()) `thenIO` \ _ -> + playGame xinfo state + + + + +promptFile xinfo state cont = + promptFor "File name:" xinfo state `thenIO` \ name -> + readFile name + (\ _ -> drawCmd ("Can't read file:" ++ name) xinfo state + `thenIO` \ _ -> + cont XNull) + (\ content -> cont (XSome content)) + +loadGame xinfo state cont = + promptFile xinfo state $ \ file -> + case file of + XNull -> cont xinfo state + XSome file_content -> + readGameState file_content `thenIO` \ new_state -> + let (GameState _ _ _ _ _ _ time _ _ _) = new_state + in + getTime `thenIO` \ curtime -> + initArray time 2 4 curtime `thenIO` \() -> + redraw xinfo new_state `thenIO` \ _ -> + playGame xinfo new_state + +saveGame :: XInfo -> GameState -> IO () +saveGame xinfo state = + promptFor "File name:" xinfo state `thenIO` \ name -> + showGameState state `thenIO` \ str -> + writeFile name str + (\ _ -> drawCmd ("Can't write file: " ++ name) xinfo state) + done + +quitGame :: XInfo -> GameState -> GameCont -> IO () +quitGame xinfo state cont = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + promptFor "Are you sure? (y/n)" xinfo state `thenIO` \ reps -> + if (reps == "y" || reps == "Y") then xCloseDisplay display + else clearCmd xinfo state `thenIO` \ _ -> + cont xinfo state + +playGame :: XInfo -> GameState -> IO () +playGame xinfo state = + let + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + xMArrayLookup numbersteps 0 `thenIO` \ x -> + (\cont -> if x == 361 + then drawCmd "It's a tie!" xinfo state `thenIO` \ _ -> + let loop xinfo state = waitButton xinfo state (\ _ -> loop) + in loop xinfo state + else cont) $ + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + getTime `thenIO` \ curtime -> + xMArrayLookup time 0 `thenIO` \ lstm0 -> + xMArrayLookup time 1 `thenIO` \ lstm1 -> + xMArrayLookup time 2 `thenIO` \ lstm2 -> + xMArrayLookup time 3 `thenIO` \ lstm3 -> + drawCmd ("Waiting for player # " ++ (show next_player_num)) xinfo state + `thenIO` \() -> + if (next_player_num == 1) + then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) + '<' `thenIO` \(trash) -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 840 180 40 40) True `thenIO` \() -> + xMArrayUpdate time 2 curtime `thenIO` \() -> + xMArrayUpdate time 1 (lstm1+curtime-lstm3) `thenIO` \() -> + showtime 705 270 (lstm1+curtime-lstm3) xinfo `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ x -> + if (x == "computer") + then computerplay xinfo state + else humanplay xinfo state + else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) + '<' `thenIO` \(trash) -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 840 40 40 40) True `thenIO` \() -> + xMArrayUpdate time 3 curtime `thenIO` \() -> + xMArrayUpdate time 0 (lstm0+curtime-lstm2) `thenIO` \() -> + showtime 705 130 (lstm0+curtime-lstm3) xinfo `thenIO` \() -> + xMArrayLookup player2 0 `thenIO` \ x -> + if (x == "computer") + then computerplay xinfo state + else humanplay xinfo state + +waitButton xinfo@(XInfo display _ _ _ _) state cont = + let + loop xinfo state = + xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state + `thenIO` \ _ -> + loop xinfo state + XButtonPressEvent -> + let pos = xEventPos event + in + handleButton pos xinfo state (cont pos) + _ -> xBell display 0 `thenIO` \ _ -> + loop xinfo state + in + loop xinfo state + +updateboard :: XInfo -> GameState -> Int -> Int -> IO () +updateboard xinfo state x y = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + xMArrayUpdate next_player 0 (if next_player_num == 1 then 2 else 1) + `thenIO` \ _ -> + xMArrayLookup numbersteps 0 `thenIO` \ z -> + xMArrayUpdate numbersteps 0 (z+1) `thenIO` \() -> + xMArrayUpdate steps (2*z) x `thenIO` \() -> + xMArrayUpdate steps (2*z+1) y `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ name1 -> + xMArrayLookup player2 0 `thenIO` \ name2 -> + xMArrayUpdate board (19*(x-1)+y-1) next_player_num + `thenIO` \() -> + human_unit board x y `thenIO` \ win -> + if win + then drawCmd ("Player " ++ (show next_player_num) ++ " has won!") + xinfo state `thenIO` \ _ -> + let loop xinfo state = waitButton xinfo state (\ _ -> loop) + in loop xinfo state + else if (name1 == "computer" || name2 == "computer") + then draw_unit board weight1 weight2 x y `thenIO` \() -> + xMArrayUpdate weight1 (19*(x-1)+y-1) (-1) `thenIO` \() -> + xMArrayUpdate weight2 (19*(x-1)+y-1) (-1) `thenIO` \() -> + playGame xinfo state + else playGame xinfo state + +choice :: XPoint -> XInfo -> GameState -> IO () +choice (XPoint x y) xinfo@(XInfo display _ _ _ _) state = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + case (getposition x y) of + XNull -> humanplay xinfo state + XSome (x, y) -> + xMArrayLookup board (19*(x-1)+y-1) `thenIO` \ z -> + if (z>0) + then xBell display 0 `thenIO` \ _ -> + drawCmd "Wrong point, please re-enter" xinfo state `thenIO` \() -> + humanplay xinfo state + else xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + drawPiece x y xinfo (next_player_num == 1) `thenIO` \() -> + updateboard xinfo state x y + +humanplay :: XInfo -> GameState -> IO () +humanplay xinfo state = waitButton xinfo state choice + +computerplay :: XInfo -> GameState -> IO () +computerplay xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state = + let process_events xinfo state cont = + xEventListen display `thenIO` \ n_event -> + if n_event == 0 then cont xinfo state + else xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XButtonPressEvent -> + handleButton (xEventPos event) xinfo state cont + XExposureEvent -> + may_redraw (xEventCount event == 0) + xinfo state + `thenIO` \ _ -> + process_events xinfo state cont + XKeyPressEvent -> + process_events xinfo state cont + in + process_events xinfo state $ + \ xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state@(GameState _ _ _ _ weight1 weight2 _ numbersteps _ next_player) -> + robot numbersteps weight1 weight2 `thenIO` \pt -> + let (XPoint x y) = pt + in + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + drawPiece x y xinfo (next_player_num == 1) `thenIO` \() -> + updateboard xinfo state x y + + + + diff --git a/progs/demo/X11/gobang/gobang.hu b/progs/demo/X11/gobang/gobang.hu new file mode 100644 index 0000000..d228bb2 --- /dev/null +++ b/progs/demo/X11/gobang/gobang.hu @@ -0,0 +1,7 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +gobang.hs +misc.hi +utilities.hs +redraw.hs +weights.hs diff --git a/progs/demo/X11/gobang/misc.hi b/progs/demo/X11/gobang/misc.hi new file mode 100644 index 0000000..29a29be --- /dev/null +++ b/progs/demo/X11/gobang/misc.hi @@ -0,0 +1,7 @@ +interface Misc where + +random :: Int -> IO Int + +{-# +random :: LispName("lisp:random") +#-}
\ No newline at end of file diff --git a/progs/demo/X11/gobang/misc.hu b/progs/demo/X11/gobang/misc.hu new file mode 100644 index 0000000..42a9c68 --- /dev/null +++ b/progs/demo/X11/gobang/misc.hu @@ -0,0 +1,2 @@ +misc.hi + diff --git a/progs/demo/X11/gobang/redraw.hs b/progs/demo/X11/gobang/redraw.hs new file mode 100644 index 0000000..9ec772f --- /dev/null +++ b/progs/demo/X11/gobang/redraw.hs @@ -0,0 +1,160 @@ +module Redraw where + +import Xlib +import Utilities + +may_redraw :: Bool -> XInfo -> GameState -> IO () +may_redraw ok xinfo state = if ok then redraw xinfo state else returnIO () + +redraw :: XInfo -> GameState -> IO () + +redraw xinfo state = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xDrawRectangle (XDrawWindow window) gcontext2 (XRect 0 0 900 600) True + `thenIO` \ _ -> + drawBoard xinfo `thenIO` \ () -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 65) "Player 1" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 125) "Clock 1" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 205) "Player 2" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 265) "Clock 2" + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 45 130 30) False + `thenIO` \ () -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 105 90 30) False + `thenIO` \ () -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 185 130 30) False + `thenIO` \() -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 245 90 30) False + `thenIO` \() -> + button 700 330 "New players" xinfo `thenIO` \() -> + button 700 360 "New game" xinfo `thenIO` \() -> + button 700 390 "Undo" xinfo `thenIO` \() -> + button 700 420 "Load" xinfo `thenIO` \() -> + button 700 450 "Save" xinfo `thenIO` \() -> + button 700 480 "Quit" xinfo `thenIO` \() -> + helpButton xinfo `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 615 535 250 30) False + `thenIO` \ _ -> + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + xMArrayLookup time 0 `thenIO` \ lstm0 -> + xMArrayLookup time 1 `thenIO` \ lstm1 -> + showtime 705 270 (lstm1) xinfo `thenIO` \() -> + showtime 705 130 (lstm0) xinfo `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ player1_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name + `thenIO` \ _ -> + xMArrayLookup player2 0 `thenIO` \ player2_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name + `thenIO` \ _ -> + xMArrayLookup promptString 0 `thenIO` \ ps -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) ps + `thenIO` \ _ -> + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + (if (next_player_num == 1) + then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) '<' + else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) '<') + `thenIO` \ _ -> + drawPieces 1 1 board xinfo `thenIO` \ _ -> + returnIO () + +drawHelp (XInfo display window gcontext gcontext2 gcontextp) = + xDrawRectangle (XDrawWindow window) gcontext2 (XRect 100 100 300 200) True + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 100 100 300 200) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 102 102 296 196) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 200 230 100 60) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 202 232 96 56) False + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 240 265) "OK" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 120) + "Two players in turn place black and white" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 135) + "pieces on the board. The winner is the" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 150) + "player who first makes five consecutive" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 165) + "pieces in either vertical, horizontal or" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 180) + "diagonal directions." + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 200) + "To play with a robot, type \"computer\" as" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 215) + "the name of another player." + + +drawBoard (XInfo display window gcontext gcontext2 gcontextp) = + drawvlines 30 30 1 `thenIO` \() -> + drawhlines 30 30 1 `thenIO` \() -> + drawmarks where + + drawvlines :: Int -> Int -> Int -> IO () + drawvlines x y z + | z <= 19 + = xDrawLine (XDrawWindow window) gcontext + (XPoint x y) (XPoint x (y+30*18)) `thenIO` \() -> + drawvlines (x+30) y (z+1) + | otherwise + = returnIO () + + drawhlines :: Int -> Int -> Int -> IO () + drawhlines x y z + | z <= 19 + = xDrawLine (XDrawWindow window) gcontext + (XPoint x y) (XPoint (x+30*18) y) `thenIO` \() -> + drawhlines x (y+30) (z+1) + | otherwise + = returnIO () + + drawmarks :: IO () + drawmarks = + map2IO (\x y -> + xDrawArc (XDrawWindow window) gcontext + (XArc x y 6 6 (-1.0) 6.283) True) + (map (\x -> 30 + x*30-3) [3,9,15,3,9,15,3,9,15]) + (map (\x -> 30 + x*30-3) [3,3,3,9,9,9,15,15,15]) + `thenIO` \ _ -> returnIO () + +map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c] + +map2IO f [] [] = returnIO [] +map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y -> + map2IO f xs zs `thenIO` \ ys -> + returnIO (y:ys) + +drawPieces 20 _ board xinfo = returnIO () +drawPieces x 20 board xinfo = drawPieces (x+1) 1 board xinfo +drawPieces x y board xinfo = + xMArrayLookup board ((x-1)*19 + y-1) `thenIO` \ piece -> + (if (piece == 1 || piece == 2) + then drawPiece x y xinfo (piece == 1) + else returnIO ()) `thenIO` \ _ -> + drawPieces x (y+1) board xinfo + +drawPiece x y (XInfo display window gcontext gcontext2 _ ) is_black = + (if is_black then returnIO () + else xDrawArc (XDrawWindow window) gcontext2 + (XArc (30*x-10) (30*y-10) 20 20 + (-1.0) 6.283) + True) `thenIO` \ _ -> + xDrawArc (XDrawWindow window) gcontext + (XArc (30*x-10) (30*y-10) 20 20 + (-1.0) 6.283) + is_black `thenIO` \ _ -> + xDisplayForceOutput display + diff --git a/progs/demo/X11/gobang/redraw.hu b/progs/demo/X11/gobang/redraw.hu new file mode 100644 index 0000000..7d5aa14 --- /dev/null +++ b/progs/demo/X11/gobang/redraw.hu @@ -0,0 +1,4 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +redraw.hs +utilities.hs diff --git a/progs/demo/X11/gobang/utilities.hs b/progs/demo/X11/gobang/utilities.hs new file mode 100644 index 0000000..fe2483b --- /dev/null +++ b/progs/demo/X11/gobang/utilities.hs @@ -0,0 +1,305 @@ +module Utilities where + +import Xlib +import Weights +import Redraw +import Misc + +data XInfo = XInfo XDisplay XWindow XGcontext XGcontext XGcontext +data GameState = GameState (XMArray String) (XMArray String) (XMArray Int) + (XMArray Int) (XMArray Int) (XMArray Int) + (XMArray Integer) (XMArray Int) + (XMArray String) (XMArray Int) + +type GameCont = XInfo -> GameState -> IO () + +xMArrayToList :: XMArray a -> IO [a] +xMArrayToList a = + let la = xMArrayLength a + loop i a = if i == la then returnIO [] + else xMArrayLookup a i `thenIO` \ x -> + loop (i+1) a `thenIO` \ xs -> + returnIO (x:xs) + in + loop 0 a + + +readGameState str = + let + [(board_lst, r1)] = reads str + [(weight1_lst, r2)] = reads r1 + [(weight2_lst, r3)] = reads r2 + [(steps_lst, r4)] = reads r3 + [(player1_lst, r5)] = reads r4 + [(player2_lst, r6)] = reads r5 + [(time_lst, r7)] = reads r6 + [(numbersteps_lst, r8)] = reads r7 + [(promptString_lst, r9)] = reads r8 + [(next_player_lst, [])] = reads r9 + in + xMArrayCreate board_lst `thenIO` \ board -> + xMArrayCreate weight1_lst `thenIO` \ weight1 -> + xMArrayCreate weight2_lst `thenIO` \ weight2 -> + xMArrayCreate steps_lst `thenIO` \ steps -> + xMArrayCreate player1_lst `thenIO` \ player1 -> + xMArrayCreate player2_lst `thenIO` \ player2 -> + xMArrayCreate time_lst `thenIO` \ time -> + xMArrayCreate numbersteps_lst `thenIO` \ numbersteps -> + xMArrayCreate promptString_lst `thenIO` \ promptString -> + xMArrayCreate next_player_lst `thenIO` \ next_player -> + returnIO (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + +showGameState (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = + xMArrayToList board `thenIO` \ board_lst -> + xMArrayToList weight1 `thenIO` \ weight1_lst -> + xMArrayToList weight2 `thenIO` \ weight2_lst -> + xMArrayToList steps `thenIO` \ steps_lst -> + xMArrayToList player1 `thenIO` \ player1_lst -> + xMArrayToList player2 `thenIO` \ player2_lst -> + xMArrayToList time `thenIO` \ time_lst -> + xMArrayToList numbersteps `thenIO` \ numbersteps_lst -> + xMArrayToList promptString `thenIO` \ promptString_lst -> + xMArrayToList next_player `thenIO` \ next_player_lst -> + let + str =(shows board_lst . + shows weight1_lst . + shows weight2_lst . + shows steps_lst . + shows player1_lst . + shows player2_lst . + shows time_lst . + shows numbersteps_lst . + shows promptString_lst . + shows next_player_lst) [] + in + returnIO str + + +xMod :: Int -> Int -> Int +xMod x y | x >= y = xMod (x-y) y + | otherwise = x + +xRes :: Int -> Int -> Int -> Int +xRes x y z | x >= y = xRes (x-y) y (z+1) + | otherwise = z + +drawCmd :: String -> XInfo -> GameState -> IO () +drawCmd a (XInfo display window gcontext gcontext2 gcontextp) + (GameState _ _ _ _ _ _ _ _ str _) + = xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \ () -> + xDrawGlyphs (XDrawWindow window) gcontext + (XPoint 620 550) a `thenIO` \ _ -> + xMArrayUpdate str 0 a `thenIO` \ _ -> + xDisplayForceOutput display + +clearCmd :: XInfo -> GameState -> IO () +clearCmd (XInfo display window gcontext gcontext2 gcontextp) + (GameState _ _ _ _ _ _ _ _ str _) + = xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \() -> + xMArrayUpdate str 0 "" `thenIO` \ _ -> + xDisplayForceOutput display + +xPosition :: Int -> XPoint +xPosition a = (XPoint (xRes a 19 1) (1+ (xMod a 19))) + +initArray :: XMArray a -> Int -> Int -> a -> IO () +initArray mary x y z | x<y = xMArrayUpdate mary x z `thenIO` \() -> + initArray mary (x+1) y z + | otherwise = returnIO () + +getposition :: Int -> Int -> XMaybe (Int, Int) +getposition x y = let x1 = round ((fromIntegral x) / 30.0) + y1 = round ((fromIntegral y) / 30.0) + in + if (x1 < 1 || x1 > 19 || y1 < 1 || y1 > 19) then XNull + else XSome (x1, y1) + +addZero :: Int -> String +addZero a | a < 10 = "0" + | otherwise = "" + +printTime :: Int -> Int -> [Int] -> XInfo -> IO() +printTime x y zs (XInfo display window gcontext gcontext2 gcontextp) + = let s = head zs + m = head (tail zs) + h = head (tail (tail zs)) + in xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (x-4) (y-24) 88 28) True `thenIO` \() -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint x y) + ((addZero h)++(show h)++":"++(addZero m)++(show m)++ + ":"++(addZero s)++(show s)) + `thenIO` \(trash) -> + xDisplayForceOutput display + +showtime :: Int -> Int -> Integer -> XInfo -> IO() +showtime x y z a = + let (curtm, c) = (decodeTime z (WestOfGMT 0)) + in printTime x y curtm a + +helpButton :: XInfo -> IO () +helpButton (XInfo display window gcontext gcontext2 gcontextp) = + xDrawRectangle (XDrawWindow window) gcontext (XRect 800 420 70 70) + False `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 802 422 66 66) + False `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 810 450) "About" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 820 470) "Gobang" + `thenIO` \ _ -> + returnIO () + +ishelp :: Int -> Int -> Bool +ishelp x y = (x > 800 && x < 870 && y > 420 && y < 490) + +button :: Int -> Int -> String -> XInfo -> IO() +button x y a (XInfo display window gcontext gcontext2 gcontextp) = + xDrawArc (XDrawWindow window) gcontext + (XArc (x-40) (y-10) 20 20 1.5708 4.7124) True `thenIO` \() -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (x-30) (y-10) 60 20) True `thenIO` \() -> + xDrawArc (XDrawWindow window) gcontext + (XArc (x+20) (y-10) 20 20 (-1.0) 6.283) True `thenIO` \() -> + xDrawGlyphs (XDrawWindow window) gcontext2 + (XPoint (x-(length a * 3)) (y+4)) a `thenIO` \(trash) -> + xDisplayForceOutput display + +-- a b are the location of the button, c d are the point where we press the +-- button. + +buttonPress :: Int -> Int -> Int -> Int -> Bool +buttonPress a b c d | (abs (c-a))<=30 && (abs (d-b))<=10 = True + | (c-a+30)*(c-a+30)+(d-b)*(d-b)<=100 = True + | (c-a-30)*(c-a-30)+(d-b)*(d-b)<=100 = True + | otherwise = False + + + +randmax :: XMArray Int -> Int -> Int -> [Int] -> IO Int +randmax a ind max mi | ind > 360 = + let lmi = length mi + in case lmi of + 0 -> returnIO (-1) + 1 -> returnIO (head mi) + _ -> random lmi `thenIO` \ i -> + returnIO (mi !! i) + | otherwise = xMArrayLookup a ind `thenIO` \ tt3 -> + if (tt3 > max) + then randmax a (ind+1) tt3 [ind] + else if (tt3 == max) + then randmax a (ind+1) max (ind:mi) + else randmax a (ind+1) max mi + +robot :: XMArray Int -> XMArray Int -> XMArray Int -> IO XPoint +robot numbersteps weight1 weight2 + = xMArrayLookup numbersteps 0 `thenIO` \(tt5) -> + if (tt5 == 0) + then returnIO (XPoint 10 10) + else + randmax weight1 0 0 [] `thenIO` \ tmp1 -> + randmax weight2 0 0 [] `thenIO` \ tmp2 -> + xMArrayLookup weight1 tmp1 `thenIO` \ tmp3 -> + xMArrayLookup weight2 tmp2 `thenIO` \ tmp4 -> + if (tmp3 >= 200) + then returnIO (xPosition tmp1) + else if (tmp3 > tmp4) + then returnIO (xPosition tmp1) + else returnIO (xPosition tmp2) + + +promptFor prompt xinfo state = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \() -> + xMArrayUpdate promptString 0 prompt `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) prompt + `thenIO` \ _ -> + xDisplayForceOutput display `thenIO` \ _ -> + let h_base = (length prompt + 1) * 6 + 620 + getString :: Int -> String -> IO String + getString h_pos sofar = + xGetEvent display `thenIO` \event -> + case (xEventType event) of + XButtonPressEvent -> + let (XPoint x y) = xEventPos event + in + (if ishelp x y then helpGame xinfo state + else xBell display 0) + `thenIO` \ _ -> + getString h_pos sofar + XExposureEvent -> + may_redraw (xEventCount event == 0) xinfo state `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint h_base 550) sofar + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * h_pos) (550-10) 6 13) True + `thenIO` \ _ -> getString h_pos sofar + XKeyPressEvent -> + let code = xEventCode event + state = xEventState event + bs = if (sofar == "") then getString h_pos sofar + else xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (h_base + 6 * h_pos) + (550-10) 6 13) + True `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * (h_pos - 1)) + (550-10) 6 13) + True `thenIO` \ _ -> + getString (h_pos-1) (take (length sofar - 1) sofar) + in + xKeycodeCharacter display code state `thenIO` \ char -> + case char of + (XSome '\r') -> returnIO sofar + (XSome '\DEL') -> bs + (XSome '\BS') -> bs + XNull -> getString h_pos sofar + (XSome c) -> xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (h_base + 6 * h_pos) + (550-10) 6 13) + True `thenIO` \ _ -> + xDrawGlyph (XDrawWindow window) gcontext + (XPoint (h_base + 6 * h_pos) 550) c + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * (h_pos + 1)) + (550-10) 6 13) + True `thenIO` \ _ -> + getString (h_pos + 1) (sofar ++ [c]) + + in + xDrawRectangle (XDrawWindow window) gcontext + (XRect h_base (550-10) 6 13) True + `thenIO` \ _ -> + getString 0 "" + + +helpGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) state = + drawHelp xinfo `thenIO` \ _ -> + let + loop xinfo state = + xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state + `thenIO` \ _ -> + drawHelp xinfo `thenIO` \ _ -> + loop xinfo state + XButtonPressEvent -> + let (XPoint x y) = xEventPos event + in + if (x > 200 && x < 300 && y > 230 && y < 290) + then redraw xinfo state `thenIO` \ _ -> + returnIO () + else loop xinfo state + _ -> xBell display 0 `thenIO` \ _ -> + loop xinfo state + in + loop xinfo state + + diff --git a/progs/demo/X11/gobang/utilities.hu b/progs/demo/X11/gobang/utilities.hu new file mode 100644 index 0000000..bfccbfe --- /dev/null +++ b/progs/demo/X11/gobang/utilities.hu @@ -0,0 +1,6 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +utilities.hs +weights.hs +redraw.hs +misc.hi diff --git a/progs/demo/X11/gobang/weights.hs b/progs/demo/X11/gobang/weights.hs new file mode 100644 index 0000000..1b55553 --- /dev/null +++ b/progs/demo/X11/gobang/weights.hs @@ -0,0 +1,323 @@ +module Weights where + +import Xlib +import Utilities + +xlookup :: XMArray Int -> Int -> Int -> IO Int +xlookup keyboard x y = + if (x < 1 || x > 19 || y < 1 || y > 19) + then returnIO (-2) + else xMArrayLookup keyboard ((x-1)*19+(y-1)) + + +draw_unit :: XMArray Int -> XMArray Int -> XMArray Int -> Int -> Int -> IO() +draw_unit keyboard weight1 weight2 x y = + let + update_weight :: XMArray Int->Int->Int->Int->Int->Int->Int->IO() + update_weight weight counter player x y incr_x incr_y + | x>=1 && x<=19 && y>=1 && y<=19 && counter<=4 = + cpt_weight x y player `thenIO` \wt -> + xMArrayUpdate weight ((x-1)*19+(y-1)) wt `thenIO` \() -> + update_weight weight (counter+1) player (x+incr_x) (y+incr_y) + incr_x incr_y + | otherwise = returnIO () +---------------------------------------------------------------------------- + + pattern0 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern0 a b c d e p | a==p && b==p && c==p && d==p && e==p = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern1 a b c d e f p | (a==0) && (b==p) && (c==p) && (d==p) && (e==p) && + (f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern2 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern2 a b c d e p | (a==0 && b==p && c==p && d==p && e==p)|| + (a==p && b==p && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern3 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern3 a b c d e p | (a==0 && b==p && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern4 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern4 a b c d p | (a==0 && b==p && c==p && d==p) || + (a==p && b==p && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern5 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern5 a b c d e f p | (a==0 && b==p && c==p && d==0 && e==p && + f==0) || + (a==0 && b==p && c==0 && d==p && e==p && + f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern6 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern6 a b c d e p | (a==0 && b==p && c==p && d==0 && e==p) || + (a==0 && b==p && c==0 && d==p && e==p) || + (a==p && b==p && c==0 && d==p && e==0) || + (a==p && b==0 && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int-> Bool + pattern7 a b c d e f g p | (a==0 && b==p && c==0 && d==p && e==0 && + f==p && g==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern8 a b c d e f p | (a==0 && b==p && c==0 && d==p && e==0 && + f==p) || + (a==p && b==0 && c==p && d==0 && e==p && + f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern9 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern9 a b c d p | (a==0 && b==p && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern10 :: Int -> Int -> Int -> Int -> Bool + pattern10 a b c p | (a==0 && b==p && c==p) || + (a==p && b==p && c==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern11 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern11 a b c d e p | (a==0 && b==p && c==0 && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern12 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern12 a b c d p | (a==0 && b==p && c==0 && d==p) || + (a==p && b==0 && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + direct1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int -> Int -> Int -> Int -> Int -> Int + direct1 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4 pl) = 200 + | (pattern1 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern1 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern1 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern1 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 40 + | (pattern2 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern2 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern2 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern2 ptN1 pt ptP1 ptP2 ptP3 pl) = 13 + | (pattern3 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern3 ptN1 pt ptP1 ptP2 ptP3 pl) = 10 + | (pattern4 ptN3 ptN2 ptN1 pt pl) || + (pattern4 ptN2 ptN1 pt ptP1 pl) || + (pattern4 ptN1 pt ptP1 ptP2 pl) = 8 + | (pattern5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern5 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern5 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern5 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 9 + | (pattern6 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern6 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern6 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern6 ptN1 pt ptP1 ptP2 ptP3 pl) = 7 + | (pattern7 ptN5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern7 ptN4 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern7 ptN3 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern7 ptN2 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) || + (pattern7 ptN1 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 6 + | (pattern8 ptN5 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern8 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern8 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern8 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern8 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) || + (pattern8 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 5 + | (pattern9 ptN2 ptN1 pt ptP1 pl) || + (pattern9 ptN1 pt ptP1 ptP2 pl) = 4 + | (pattern10 ptN2 ptN1 pt pl) || + (pattern10 ptN1 pt ptP1 pl) || + (pattern10 pt ptP1 ptP2 pl) = 2 + | (pattern11 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern11 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern11 ptN1 pt ptP1 ptP2 ptP3 pl) = 3 + | (pattern12 ptN3 ptN2 ptN1 pt pl) || + (pattern12 ptN2 ptN1 pt ptP1 pl) || + (pattern12 ptN1 pt ptP1 ptP2 pl) || + (pattern12 pt ptP1 ptP2 ptP3 pl) = 1 + | otherwise = 0 +---------------------------------------------------------------------------- + + direct2 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int -> Int -> Int -> Int -> Int -> Int + direct2 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4 pl) = 200 + | otherwise = 0 +----------------------------------------------------------------------------- + + cpt_weight :: Int -> Int -> Int -> IO Int + cpt_weight x y player = + xMArrayLookup keyboard ((x-1)*19+(y-1)) `thenIO` \(unit) -> + if (unit /= 0) + then returnIO (-1) + else xlookup keyboard x (y-1) `thenIO` \(xyN1) -> + xlookup keyboard x (y-2) `thenIO` \(xyN2) -> + xlookup keyboard x (y-3) `thenIO` \(xyN3) -> + xlookup keyboard x (y-4) `thenIO` \(xyN4) -> + xlookup keyboard x (y-5) `thenIO` \(xyN5) -> + xlookup keyboard x (y+1) `thenIO` \(xyP1) -> + xlookup keyboard x (y+2) `thenIO` \(xyP2) -> + xlookup keyboard x (y+3) `thenIO` \(xyP3) -> + xlookup keyboard x (y+4) `thenIO` \(xyP4) -> + xlookup keyboard x (y+5) `thenIO` \(xyP5) -> + xlookup keyboard (x-1) y `thenIO` \(xN1y) -> + xlookup keyboard (x-2) y `thenIO` \(xN2y) -> + xlookup keyboard (x-3) y `thenIO` \(xN3y) -> + xlookup keyboard (x-4) y `thenIO` \(xN4y) -> + xlookup keyboard (x-5) y `thenIO` \(xN5y) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + xlookup keyboard (x+5) y `thenIO` \(xP5y) -> + xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)-> + xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) -> + xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) -> + xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) -> + xlookup keyboard (x-5) (y-5) `thenIO` \(xN5yN5) -> + xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) -> + xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) -> + xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) -> + xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) -> + xlookup keyboard (x+5) (y+5) `thenIO` \(xP5yP5) -> + xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> + xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) -> + xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> + xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> + xlookup keyboard (x-5) (y+5) `thenIO` \(xN5yP5) -> + xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> + xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> + xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> + xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> + xlookup keyboard (x+5) (y-5) `thenIO` \(xP5yN5) -> + returnIO ( (direct1 x y player xyN1 xyN2 xyN3 xyN4 xyN5 player + xyP1 xyP2 xyP3 xyP4 xyP5) + + (direct1 x y player xN1y xN2y xN3y xN4y xN5y player + xP1y xP2y xP3y xP4y xP5y) + + (direct1 x y player xN1yN1 xN2yN2 xN3yN3 xN4yN4 + xN5yN5 player xP1yP1 xP2yP2 xP3yP3 xP4yP4 + xP5yP5) + + (direct1 x y player xN1yP1 xN2yP2 xN3yP3 xN4yP4 + xN5yP5 player xP1yN1 xP2yN2 xP3yN3 xP4yN4 + xP5yN5) ) +----------------------------------------------------------------------------- + +-- | 1111 && no_block = 20 +-- | 1111 && one_block = 13 +-- | 111 && no_block = 10 +-- | 111 && one_block = 8 +-- | 11 1 or 1 11 && no_block = 9 +-- | 11 1 or 1 11 && one_block =7 +-- | 1 1 1 && no_block = 6 +-- | 1 1 1 && one_block= 5 +-- | 11 && no_block = 4 +-- | 11 && one_block =2 +-- | 1 1 && no_block =3 +-- | 1 1 && one_block=1 + + in + update_weight weight1 0 1 x y 1 1 `thenIO` \() -> + update_weight weight2 0 2 x y 1 1 `thenIO` \() -> + update_weight weight1 0 1 x y 1 (-1) `thenIO` \() -> + update_weight weight2 0 2 x y 1 (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) (-1) `thenIO` \() -> + update_weight weight2 0 2 x y (-1) (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) 1 `thenIO` \() -> + update_weight weight2 0 2 x y (-1) 1 `thenIO` \() -> + update_weight weight1 0 1 x y 0 1 `thenIO` \() -> + update_weight weight2 0 2 x y 0 1 `thenIO` \() -> + update_weight weight1 0 1 x y 0 (-1) `thenIO` \() -> + update_weight weight2 0 2 x y 0 (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) 0 `thenIO` \() -> + update_weight weight2 0 2 x y (-1) 0 `thenIO` \() -> + update_weight weight1 0 1 x y 1 0 `thenIO` \() -> + update_weight weight2 0 2 x y 1 0 `thenIO` \() -> + returnIO () + + +human_unit :: XMArray Int -> Int -> Int -> IO(Bool) +human_unit keyboard x y = + let + pattern0 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern0 a b c d e | a==b && b==c && c==d && d==e = True + | otherwise = False + + direct3 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int + direct3 ptN1 ptN2 ptN3 ptN4 pt ptP1 ptP2 ptP3 ptP4 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4) = 200 + | otherwise = 0 + in + xlookup keyboard x y `thenIO` \(xy) -> + xlookup keyboard x (y-1) `thenIO` \(xyN1) -> + xlookup keyboard x (y-2) `thenIO` \(xyN2) -> + xlookup keyboard x (y-3) `thenIO` \(xyN3) -> + xlookup keyboard x (y-4) `thenIO` \(xyN4) -> + xlookup keyboard x (y+1) `thenIO` \(xyP1) -> + xlookup keyboard x (y+2) `thenIO` \(xyP2) -> + xlookup keyboard x (y+3) `thenIO` \(xyP3) -> + xlookup keyboard x (y+4) `thenIO` \(xyP4) -> + xlookup keyboard (x-1) y `thenIO` \(xN1y) -> + xlookup keyboard (x-2) y `thenIO` \(xN2y) -> + xlookup keyboard (x-3) y `thenIO` \(xN3y) -> + xlookup keyboard (x-4) y `thenIO` \(xN4y) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)-> + xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) -> + xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) -> + xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) -> + xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) -> + xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) -> + xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) -> + xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) -> + xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> + xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) -> + xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> + xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> + xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> + xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> + xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> + xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + if ((direct3 xyN1 xyN2 xyN3 xyN4 xy xyP1 xyP2 xyP3 xyP4) + + (direct3 xN1y xN2y xN3y xN4y xy xP1y xP2y xP3y xP4y) + + (direct3 xN1yN1 xN2yN2 xN3yN3 xN4yN4 xy xP1yP1 xP2yP2 xP3yP3 xP4yP4) + + (direct3 xN1yP1 xN2yP2 xN3yP3 xN4yP4 xy xP1yN1 xP2yN2 xP3yN3 xP4yN4)) + >=200 + then returnIO (True) + else returnIO (False)
\ No newline at end of file diff --git a/progs/demo/X11/gobang/weights.hu b/progs/demo/X11/gobang/weights.hu new file mode 100644 index 0000000..f13aba0 --- /dev/null +++ b/progs/demo/X11/gobang/weights.hu @@ -0,0 +1,4 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +weights.hs +utilities.hs diff --git a/progs/demo/X11/graphics/README b/progs/demo/X11/graphics/README new file mode 100644 index 0000000..77a2d66 --- /dev/null +++ b/progs/demo/X11/graphics/README @@ -0,0 +1,31 @@ +HENDERSON GRAPHICS LIBRARY +by Syam Gadde +and Bo Whong + +------------------------------------------------- + +To use the Henderson Library, run emacs with a module that +imports HendersonLib, such as "sqrlmt.hs". For "sqrlmt.hs", +run the dialogue "final" or "skewedfinal". + +------------------------------------------------- + +henderson.hs - Haskell source for the Henderson library. +henderson.hu +sqrlmt.hs - Haskell source for dialogue that draws "Square Limit". +sqrlmt.hu +p.pic - First of four pictures used to construct "Square Limit". +q.pic - Second of four pictures used to construct "Square Limit". +r.pic - Third of four pictures used to construct "Square Limit". +s.pic - Four of four pictures used to construct "Square Limit". +new.pic - Hudak's house +stop.pic - A "hand-drawn" stop sign border +text.pic - The word "STOP!" (hand-drawn) +strange.pic - Overlays stop.pic and Flip of text.pic +squarebox.xwd - A window dump of a box-like structure made of four + square limits. Use "xwud -in squarebox.xwd" to view. +sksl.xwd - A window dump of "squarelimit" in a skewed bounding box. + ("skewedfinal" from sqrlmt.hs.) +sl.xwd - A window dump of Square Limit. + ("squarelimit" from sqrlmt.hs.) +manual - The manual in Island Write format. 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 + + + + diff --git a/progs/demo/X11/graphics/henderson.hu b/progs/demo/X11/graphics/henderson.hu new file mode 100644 index 0000000..e92b66d --- /dev/null +++ b/progs/demo/X11/graphics/henderson.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +henderson.hs diff --git a/progs/demo/X11/graphics/manual b/progs/demo/X11/graphics/manual new file mode 100644 index 0000000..17772f1 --- /dev/null +++ b/progs/demo/X11/graphics/manual @@ -0,0 +1,454 @@ +104 pgscriptver + +100 DefSpaceEx 100 DefCharEx 1 DefNormalHyphenationOn 100 +DefTypeColor (Times-Roman) DefTypeFace ENGLISH DefLanguage 12 DefPointSize +USE_POINTSIZE DefSetSize (@default) DefTypeResource + +LEFT DefJustifyFlags 2 DefBeginParaLeadValue ABSOLUTE DefBeginParaLeadMode 2 +DefEndParaLeadValue ABSOLUTE DefEndParaLeadMode 120 DefLeadValue +PROPORTIONAL DefLeadMode 1 46 0 TAB_LEFT 720 DefTab 1 46 0 +TAB_LEFT 2160 DefTab 1 46 0 TAB_LEFT 3600 DefTab 1 46 0 +TAB_LEFT 5040 DefTab 1 46 0 TAB_LEFT 6480 DefTab 1 46 0 +TAB_LEFT 7920 DefTab 1 46 0 TAB_LEFT 9360 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 80 DefWSMN 100 DefWSNM 150 DefWSMX 110 +DefLSMX 100 DefLeaderEx 46 DefLeaderChar 0 DefFirstIndent 0 +DefLeftIndent 0 DefRightIndent 0 DefNumberingOn 0 DefNumberingType 0 +DefNumberingRestart 1 DefNumberingLevel 0 DefNumberingStyle 0 +DefNumberingTabAfter 1 DefNumberingShowAllLevels 1 DefNumberingStart 1 +DefNumberingIncrement () DefNumberingPrefix () DefNumberingSuffix (.) +DefNumberingSeparator (*default) DefParaResource + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResource + +0 DefPageDimensions 12240 DefPageWidth 15840 DefPageHeight 1440 +DefInsideMargin 1080 DefOutsideMargin 1080 DefTopMargin 1080 +DefBottomMargin 0 DefOrientation 0 DefPageStyle 1 DefColumns 360 +DefGutter (%default) DefMasterPage ResDefEnd + +0 DefFirstLeft 0 DefDocSetup 1 DefNumPages 1 AutoPage 1 +DefStartPageNum () DefPageNumPrefix 1 DefGraphicLocation document + +1 DefAutoPage +0 (%default) 1 DefPage +1 DefAutoPage +0 (%default) 2 DefPage + +POLY_OBJECT POLY_EMPTY | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 0 +DefMasterRef +MP_CPSUCC_LINK MP_CPPRED_LINK POLY_COLUMN | | DefSLinksFlags 0 DefStreamSucc 0 +DefStreamPred +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_EMPTY | (%default) 0 1 TextPolygon + +POLY_OBJECT POLY_TEXT | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 +DefMasterRef + +MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | +DefSLinksFlags 4 DefStreamSucc 0 DefStreamPred 3 DefTextHandle +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_TEXT | (1) 0 2 TextPolygon + +3 asciitextstream +<(Courier) cf ><9 cs>The Henderson Library--<eop> +by Syam Gadde<eop> +and Bo Whong<eop> +<eop> +The Henderson Library is a toolkit with which one can use Functional Geometry, +as proposed by Peter Henderson in his paper "Functional Geometry". This is a s +cheme by which "Picture"s can be described in an abstract data type, and a numb +er of functions can be applied to it. This results in a very elegant method to + produce complex pictures from simple ones. The example Henderson uses is "Squ +are Limit" by M. C. Escher, which can be constructed with four simple pictures +.<eop> +<eop> +------------------------<eop> +ADTs and Type Synonyms<eop> +<eop> +The Picture data type is composed of eight different types of pictures. They a +re:<eop> +<eop> +data<eop> +Picture = Nil - empty picture<eop> + | Flip Picture - picture flipped on the y-axis<e +op> + | Beside Float Picture Float Picture - two pictures placed side by sid +e <eop> + - in accordance to the ratio of t +he<eop> + - two floats<eop> + | Above Float Picture Float Picture - two pictures placed one on top +of<eop> + - another in accordance to the ra +tio<eop> + - of the two floats<eop> + | Rot Picture - picture is rotated 90 degrees < +eop> + - counterclockwise<eop> + | File String - picture is stored as an externa +l<eop> + - file<eop> + | Overlay Picture Picture - two pictures are drawn such tha +t<eop> + - one lays on top of the other<eo +p> + | Grid Int Int SegList - picture type that contains the +list<eop> + - of picture's line segments alon +g<eop> + - with the size of the inital pic +ture<eop> +<eop> +The type synonyms are pretty much self explanatory.<eop> +<eop> + Hostname<tab><tab><tab>- a string of the hostname<eop> + Filename <tab>- a string of the filename<e +op> + IntPoint <tab>- a tuple of integers repres +enting<eop> + <tab>- the coordinates of a point +<eop> + IntSegment <tab>- a tuple of Intpoints repre +senting<eop> + <tab>- the endpoints of a line se +gment<eop> + IntSegList <tab>- a list of IntSegments <eop +> + Point <tab>- same as IntPoint except in + place of<eop> +<tab><tab><tab> <tab>- intergers, they are floating points<eop> + Segment <tab>- same as IntSegment except +in place<eop> + <tab><tab> <tab>- of intergers, they are floating <eop> + <tab><tab><tab>- points<eop> + SegList <tab>- same as IntsegList except +in place<eop> + <tab><tab><tab><tab>- of intergers, they are floating <eop> + <tab><tab><tab>- points<eop> + Vector <tab>- a tuple of floating points + to<eop> + <tab><tab><tab>- to represent a vector<eop> + Vtriple - a 3-tuple of Vectors<eop> + HendQuartet - a 4-tuple of Integers for the s +ize<eop> + - of the Henderson window<eop> + PEnv - a tuple of a Filename and a Pic +ture<eop> + - for storing already opened file +s in<eop> + - in order to save time and memor +y<eop> + - when a file needs to be opened +more<eop> + - than once<eop> +<eop> +------------------------------------------------------------------------------- +----<eop> +Function: create (an exported function from the HendersonLib)<eop> +<eop> +The purpose of the create function is to provide the user with a function to <e +op> +draw a picture from a graphics interface. The user may choose to create a pict +ure<eop> +file by inputing the the lines and points manually into a file or (s)he may cho +ose<eop> +to use the create function.<eop> +<eop> +Functionality of create:<eop> + create :: Hostname -<ra> Filaname -<ra> Int -<ra> Int -<ra> IO()<eop +> +<eop> +create takes as input a hostname, a filename, and two integers for the size of +the <eop> +window to be opened. Two windows should appear, one for the input of lines and +<eop> +another showing the current position of the mouse. These windows will be label +ed<eop> +accordingly.<eop> +To draw a line on the file window, move the cursor to the desired position, the +n<eop> +hit any key on the keybroad. This point will be the beginning of the line segme +nt.<eop> +Next move the cursor to the position of where the user wants the end of the lin +e<eop> +segment to be, then hit any key from the keyboard again. A line should appear. +<eop> +The coordinates of the endpoints of each line drawn will also be printed out o +nto <eop> +standard output.<eop> +To signal completion of a file, press any button on the mouse. The user must < +eop> +remember though that this is only applicable after a completed drawing of a lin +e.<eop> +For example, pressing the mouse button will not work if one of the endpoints of + a<eop> +line is drawn but the other endpoint is not. create will not recognize the mous +e <eop> +button press event until a second endpoint is drawn.<eop> +<eop> +Advantages of create:<eop> + provides a quick and fun way to create a picture file.<eop> +<eop> +Disadvantages of create:<eop> + If the file does not exist, create will create the file and then store the pic +ture<eop> + to it. However, if the file exists, create will automatically delete the cont +ents<eop> + of that file before storing the new picture.<eop> +<eop> +------------------------------------------------------------------------------- +----<eop> +Function: modify (an exported function from the HendersonLib)<eop> +<eop> +The purpose of the modify function is to provide the user with a function make +<eop> +additions to an already existing picture file using a graphics interface. The +user<eop> +may choose to modify the picture file by adding the the lines and points manual +ly <eop> +into the file or (s)he may choose to use the modify function.<eop> +<eop> +Functionality of modify:<eop> + modify :: Hostname -<ra> Filaname -<ra> IO()<eop> +<eop> +modify takes as input a hostname and a filename. Tow windows should appear. Th +e <eop> +size of the draw window will be the same as the x and y coordinates already in +the<eop> +file. These windows will be labeled accordingly. The existing picture will app +ear<eop> +first before any input is allowed.<eop> +To draw a line on the file window, move the cursor to the desired position, the +n<eop> +hit any key on the keybroad. This point will be the beginning of the line segme +nt.<eop> +Next move the cursor to the position of where the user wants the end of the lin +e<eop> +segment to be, then hit any key from the keyboard again. A line should appear. +<eop> +The coordinates of the endpoints of each line drawn will also be printed out o +nto <eop> +standard output.<eop> +To signal completion of a file, press any button on the mouse. The user must < +eop> +remember though that this is only applicable after a completed drawing of a lin +e.<eop> +For example, pressing the mouse button will not work if one of the endpoints of + a<eop> +line is drawn but the other endpoint is not. modify will not recognize the mou +se <eop> +button press event until a second endpoint is drawn.<eop> +<eop> +Advantages of modify:<eop> + provides a quick and fun way to modify a picture file without having to go int +o<eop> + the file and manually add on the coordinates of the additional lines<eop> +<eop> +Disadvantages of modify:<eop> + Existing lines can not be deleted and any additional lines, whether intentiona +l or<eop> + unintentional, will be appended to the picture and stored in the file.<eop> +<eop> +--------------------------------------------------------<eop> +Function: sendToDraw<eop> +<eop> +Type of sendToDraw:<eop> + sendToDraw :: XWindow -<ra> XScreen -<ra> XDisplay -<ra> <eop> + XPixel -<ra> XPixel -<ra> Plot -<ra> IO()<eop> +<eop> +Usage:<eop> + sendToDraw win scn dis fg_color bg_color plt<eop> +<eop> +'sendToDraw' is the most primitive function in the part of the Henderson<eop> +library that deals with X windows, and therefore, can be used as a very<eop> +powerful tool. It draws a Plot plt (see 'plot' function) in the given XWindow< +eop> +win, and on the given XScreen and XDisplay scn and dis, drawing the lines in<eo +p> +the foreground color. This function allows the programmer to draw more than<eo +p> +one Picture to the same window.<eop> +<eop> +Arguments:<eop> + win - the XWindow in which to draw plt<eop> + scn - the screen which contains win<eop> + dis - the display which contains scn<eop> + fg_color - an XPixel the color of which the plt will be drawn in. Note that< +eop> +<tab>this allows the programmer to draw different plt's in different colors.<eo +p> + bg_color - unused, but required.<eop> +--------------------------------------------------------<eop> +Function: plot<eop> +<eop> +Type of 'plot':<eop> + plot :: Picture -<ra> VTriple -<ra> PEnv -<ra> ((Plot, PEnv) -<ra> IO()) -<ra +> IO()<eop> +<eop> +Usage:<eop> + plot pic (a,b,c) env func<eop> +<eop> +The 'plot' function is needed to create a Plot which would be normally sent to< +eop> +a function such as sendToDraw. 'plot' converts a Picture pic into a format<eop +> +that sendToDraw can deal with.<eop> +'plot' also takes three vectors which specify the bounding box in which the<eop +> +Picture is to be drawn. The first vector (a) specifies the upper left corner<e +op> +of the bounding box. The next two vectors specify the bounding box itself,<eop +> +with respect to the first vector. This allows for non-rectangular bounding<eop +> +boxes. For example, the vector triple ((50,50), (100,0), (0,100)) specifies<eo +p> +the following bounding box:<eop> +<eop> + (0,0)----------------------------------<eop> + |<eop> + | (50,50)<eop> + | _______________ (150,0) <eop> + | | |<eop> + | | |<eop> + | | |<eop> + | | |<eop> + | | |<eop> + | |_____________| (150,150)<eop> + | (0,150)<eop> +<eop> +<eop> +A vector triple of ((0,0), (100,300), (0,100)) would specify:<eop> +<eop> + (0,0)-------------------------------------<eop> + ||\<eop> + || \<eop> + || \<eop> + (0,100)|| \<eop> + |\ \<eop> + | \ \<eop> + | \ \<eop> + | \ \ (100,300)<eop> + | \ | <eop> + | \ |<eop> + | \ |<eop> + | \| (100,400)<eop> +<eop> +Arguments: <eop> + pic - the Picture to be converted<eop> + a - a vector specifying the upper left corner of the bounding box<eop> +<tab>of the picture.<eop> + b - a vector understood to start at 'a' and specifying the upper edge of<eop> + +<tab>the bounding box.<eop> + c - a vector understood to start at 'a' and specifying the left edge of<eop> +<tab>the bounding box.<eop> +--------------------------------------------------------<eop> +Function: draw<eop> +<eop> +Type of draw:<eop> + draw :: Hostname -<ra> Picture -<ra> VTriple -<ra> HendQuartet -<ra> IO()<eop +> +<eop> +Usage:<eop> + draw host pic (a,b,c) (m,n,p,q)<eop> +<eop> +'draw' is a higher-level function than sendToDraw, and is useful to use when<eo +p> +the programmer wishes only to draw one Picture on the screen. This function<eo +p> +does most of the work that the programmer would normally have to do when using< +eop> +sendToDraw. 'draw' opens a window at host with upper left coordinates m and n< +eop> +(on an X server that lets the user position any child window of the root<eop> +window, these coordinates mean nothing), and with width p and height q.<eop> +'draw' then calls 'plot' on pic and (a,b,c) and sends the result to sendToDraw, +<eop> +which finally draws the picture to the window.<eop> +<eop> +Arguments:<eop> + host - host on which to open a display, i.e. "tucan:0"<eop> + pic - the Picture to be drawn<eop> + (a,b,c) - the vector triple specifying the bounding box to be sent to<eop> +<tab>plot (see 'plot' function)<eop> + (m,n,p,q) - upper left corner x (m), upper left corner y (n), width (p),<eop> + +<tab>and height (q), of window to be opened.<eop> +<eop> +-----------------------------------------------------------<eop> +<eop> +Module: SquareLimit<eop> +<eop> +This module is a sample user module that can be used to draw Square Limit, a wo +odcut by M. C. Escher. To draw "SquareLimit" on your host, run the dialogue:<e +op> +<tab>final host<eop> +where 'host' is the host running X, such as "turtle:0".<eop> +<eop> +To draw a slightly more interesting picture, tun the dialogue:<eop> +<tab>skewedfinal host<eop> +and it will draw "SquareLimit" in a bounding box shaped as a diamond.<eop> +<eop> + +<textstream_end> + +POLY_OBJECT POLY_TEXT | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 +DefMasterRef + +MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | +DefSLinksFlags 0 DefStreamSucc 2 DefStreamPred 3 DefTextHandle +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_TEXT | (2) 0 4 TextPolygon + +BeginProfile +(Number of Pages) (5) DefProfileString +(Language) (ENGLISH) DefProfileString +(Version) (IslandWrite Version 2.3) DefProfileString +(Creation Date) (gadde May 7, 1993 3:55 PM) DefProfileString +(Text Formats) (default) DefProfileString +(Container Formats) (default) DefProfileString +(Page Formats) (default) DefProfileString +(Fonts) (Courier) DefProfileString +(Fonts) (Times-Roman) DefProfileString +(File Path) () DefProfileString +(External Contents) () DefProfileString +(Title) () DefProfileString +(Status) () DefProfileString +(Distribution List) () DefProfileString +(Preparer) () DefProfileString +(Owner) () DefProfileString +(Author) () DefProfileString +(Superseded Documents) () DefProfileString +EndProfile + +pgscriptdone diff --git a/progs/demo/X11/graphics/p.pic b/progs/demo/X11/graphics/p.pic new file mode 100644 index 0000000..240b386 --- /dev/null +++ b/progs/demo/X11/graphics/p.pic @@ -0,0 +1 @@ +Grid 640 640 [((560.00000000000000,560.00000000000000),(440.00000000000000,640.00000000000000)), ((640.00000000000000,560.00000000000000),(560.00000000000000,560.00000000000000)), ((520.00000000000000,440.00000000000000),(640.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(520.00000000000000,440.00000000000000)), ((480.00000000000000,360.00000000000000),(360.00000000000000,400.00000000000000)), ((480.00000000000000,360.00000000000000),(640.00000000000000,400.00000000000000)), ((480.00000000000000,280.00000000000000),(640.00000000000000,320.00000000000000)), ((320.00000000000000,320.00000000000000),(480.00000000000000,280.00000000000000)), ((280.00000000000000,400.00000000000000),(160.00000000000000,440.00000000000000)), ((160.00000000000000,240.00000000000000),(280.00000000000000,400.00000000000000)), ((160.00000000000000,440.00000000000000),(160.00000000000000,240.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,320.00000000000000)), ((0.0000000000000000,320.00000000000000),(0.0000000000000000,520.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,520.00000000000000)), ((240.00000000000000,640.00000000000000),(160.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(440.00000000000000,640.00000000000000)), ((320.00000000000000,320.00000000000000),(400.00000000000000,480.00000000000000)), ((160.00000000000000,120.00000000000000),(320.00000000000000,320.00000000000000)), ((0.0000000000000000,0.0000000000000000),(160.00000000000000,120.00000000000000)), ((640.00000000000000,240.00000000000000),(320.00000000000000,160.00000000000000)), ((640.00000000000000,40.000000000000000),(560.00000000000000,0.0000000000000000)), ((520.00000000000000,40.000000000000000),(640.00000000000000,80.000000000000000)), ((480.00000000000000,0.0000000000000000),(520.00000000000000,40.000000000000000)), ((480.00000000000000,80.000000000000000),(400.00000000000000,0.0000000000000000)), ((640.00000000000000,120.00000000000000),(480.00000000000000,80.000000000000000)), ((480.00000000000000,160.00000000000000),(640.00000000000000,160.00000000000000)), ((320.00000000000000,0.0000000000000000),(480.00000000000000,160.00000000000000)), ((240.00000000000000,40.000000000000000),(320.00000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(240.00000000000000,40.000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/q.pic b/progs/demo/X11/graphics/q.pic new file mode 100644 index 0000000..84e27a4 --- /dev/null +++ b/progs/demo/X11/graphics/q.pic @@ -0,0 +1,2 @@ +Grid 16 16 +[((10.000000000000000,6.0000000000000000),(9.0000000000000000,4.0000000000000000)), ((12.000000000000000,4.0000000000000000),(10.000000000000000,6.0000000000000000)), ((9.0000000000000000,4.0000000000000000),(12.000000000000000,4.0000000000000000)), ((0.0000000000000000,6.0000000000000000),(7.0000000000000000,5.0000000000000000)), ((0.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((0.0000000000000000,0.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((15.000000000000000,16.000000000000000),(16.000000000000000,14.000000000000000)), ((16.000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((13.000000000000000,16.000000000000000),(16.000000000000000,10.000000000000000)), ((13.000000000000000,12.000000000000000),(12.000000000000000,16.000000000000000)), ((16.000000000000000,8.0000000000000000),(13.000000000000000,12.000000000000000)), ((15.000000000000000,6.0000000000000000),(16.000000000000000,8.0000000000000000)), ((16.000000000000000,0.0000000000000000),(15.000000000000000,6.0000000000000000)), ((10.000000000000000,16.000000000000000),(14.000000000000000,5.0000000000000000)), ((10.000000000000000,10.000000000000000),(10.000000000000000,7.0000000000000000)), ((8.0000000000000000,16.000000000000000),(10.000000000000000,10.000000000000000)), ((8.0000000000000000,11.000000000000000),(8.0000000000000000,8.0000000000000000)), ((6.0000000000000000,16.000000000000000),(8.0000000000000000,11.000000000000000)), ((6.0000000000000000,11.000000000000000),(4.0000000000000000,16.000000000000000)), ((6.0000000000000000,9.0000000000000000),(6.0000000000000000,11.000000000000000)), ((4.0000000000000000,11.000000000000000),(4.0000000000000000,9.0000000000000000)), ((2.0000000000000000,16.000000000000000),(4.0000000000000000,11.000000000000000)), ((4.0000000000000000,9.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((6.0000000000000000,9.0000000000000000),(4.0000000000000000,9.0000000000000000)), ((12.000000000000000,6.0000000000000000),(6.0000000000000000,9.0000000000000000)), ((16.000000000000000,0.0000000000000000),(12.000000000000000,6.0000000000000000)), ((9.0000000000000000,3.0000000000000000),(8.0000000000000000,1.0000000000000000)), ((11.000000000000000,1.0000000000000000),(9.0000000000000000,3.0000000000000000)), ((8.0000000000000000,1.0000000000000000),(11.000000000000000,1.0000000000000000)), ((8.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((6.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(4.0000000000000000,0.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(5.0000000000000000,2.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((2.0000000000000000,0.0000000000000000),(3.0000000000000000,3.0000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/r.pic b/progs/demo/X11/graphics/r.pic new file mode 100644 index 0000000..6e37979 --- /dev/null +++ b/progs/demo/X11/graphics/r.pic @@ -0,0 +1,2 @@ +Grid 32 32 +[((32.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((32.000000000000000,4.0000000000000000),(30.000000000000000,2.0000000000000000)), ((28.000000000000000,4.0000000000000000),(32.000000000000000,8.0000000000000000)), ((32.000000000000000,12.000000000000000),(26.000000000000000,6.0000000000000000)), ((24.000000000000000,8.0000000000000000),(32.000000000000000,16.000000000000000)), ((22.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((22.000000000000000,12.000000000000000),(12.000000000000000,0.0000000000000000)), ((32.000000000000000,20.000000000000000),(22.000000000000000,12.000000000000000)), ((24.000000000000000,26.000000000000000),(10.000000000000000,22.000000000000000)), ((32.000000000000000,32.000000000000000),(24.000000000000000,26.000000000000000)), ((16.000000000000000,28.000000000000000),(24.000000000000000,32.000000000000000)), ((6.0000000000000000,26.000000000000000),(16.000000000000000,28.000000000000000)), ((16.000000000000000,32.000000000000000),(4.0000000000000000,28.000000000000000)), ((2.0000000000000000,30.000000000000000),(8.0000000000000000,32.000000000000000)), ((0.0000000000000000,32.000000000000000),(16.000000000000000,16.000000000000000)), ((0.0000000000000000,24.000000000000000),(10.000000000000000,12.000000000000000)), ((4.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((28.000000000000000,20.000000000000000),(32.000000000000000,24.000000000000000)), ((16.000000000000000,16.000000000000000),(28.000000000000000,20.000000000000000)), ((4.0000000000000000,8.0000000000000000),(16.000000000000000,16.000000000000000)), ((2.0000000000000000,4.0000000000000000),(4.0000000000000000,8.0000000000000000)), ((2.0000000000000000,4.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(2.0000000000000000,4.0000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/s.pic b/progs/demo/X11/graphics/s.pic new file mode 100644 index 0000000..74659b7 --- /dev/null +++ b/progs/demo/X11/graphics/s.pic @@ -0,0 +1 @@ +Grid 32 32 [((24.000000000000000,0.0000000000000000),(32.000000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(16.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(32.000000000000000,12.000000000000000)), ((32.000000000000000,8.0000000000000000),(28.000000000000000,10.000000000000000)), ((26.000000000000000,6.0000000000000000),(32.000000000000000,4.0000000000000000)), ((26.000000000000000,6.0000000000000000),(24.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(26.000000000000000,6.0000000000000000)), ((32.000000000000000,16.000000000000000),(30.000000000000000,14.000000000000000)), ((30.000000000000000,16.000000000000000),(26.000000000000000,18.000000000000000)), ((30.000000000000000,22.000000000000000),(30.000000000000000,16.000000000000000)), ((26.000000000000000,18.000000000000000),(30.000000000000000,22.000000000000000)), ((24.000000000000000,24.000000000000000),(20.000000000000000,20.000000000000000)), ((24.000000000000000,18.000000000000000),(24.000000000000000,24.000000000000000)), ((20.000000000000000,20.000000000000000),(24.000000000000000,18.000000000000000)), ((20.000000000000000,0.0000000000000000),(22.000000000000000,12.000000000000000)), ((14.000000000000000,6.0000000000000000),(16.000000000000000,0.0000000000000000)), ((14.000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((14.000000000000000,6.0000000000000000),(14.000000000000000,16.000000000000000)), ((20.000000000000000,24.000000000000000),(16.000000000000000,20.000000000000000)), ((32.000000000000000,32.000000000000000),(20.000000000000000,24.000000000000000)), ((16.000000000000000,28.000000000000000),(32.000000000000000,32.000000000000000)), ((8.0000000000000000,28.000000000000000),(16.000000000000000,28.000000000000000)), ((0.0000000000000000,32.000000000000000),(8.0000000000000000,28.000000000000000)), ((0.0000000000000000,24.000000000000000),(4.0000000000000000,30.000000000000000)), ((0.0000000000000000,20.000000000000000),(14.000000000000000,24.000000000000000)), ((0.0000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((0.0000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((0.0000000000000000,8.0000000000000000),(14.000000000000000,12.000000000000000)), ((0.0000000000000000,4.0000000000000000),(14.000000000000000,6.0000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/sqrlmt.hs b/progs/demo/X11/graphics/sqrlmt.hs new file mode 100644 index 0000000..662cdfa --- /dev/null +++ b/progs/demo/X11/graphics/sqrlmt.hs @@ -0,0 +1,177 @@ +-- Peter Henderson's Recursive Geometry +-- Syam Gadde and Bo Whong +-- CS429 Project +-- SquareLimit User Program + +module SqrLimit where +import HendersonLib +import Xlib +{- +p = File "p.pic" + +q = File "q.pic" + +r = File "r.pic" + +s = File "s.pic" +-} +p = Grid 640 640 [((560.0,560.0),(440.0,640.0)), + ((640.0,560.0),(560.0,560.0)), + ((520.0,440.0),(640.0,480.0)), + ((400.0,480.0),(520.0,440.0)), + ((480.0,360.0),(360.0,400.0)), + ((480.0,360.0),(640.0,400.0)), + ((480.0,280.0),(640.0,320.0)), + ((320.0,320.0),(480.0,280.0)), + ((280.0,400.0),(160.0,440.0)), + ((160.0,240.0),(280.0,400.0)), + ((160.0,440.0),(160.0,240.0)), + ((120.0,480.0),(0.0,320.0)), + ((0.0,320.0),(0.0,520.0)), + ((120.0,480.0),(0.0,520.0)), + ((240.0,640.0),(160.0,480.0)), + ((400.0,480.0),(440.0,640.0)), + ((320.0,320.0),(400.0,480.0)), + ((160.0,120.0),(320.0,320.0)), + ((0.0,0.0),(160.0,120.0)), + ((640.0,240.0),(320.0,160.0)), + ((640.0,40.0),(560.0,0.0)), + ((520.0,40.0),(640.0,80.0)), + ((480.0,0.0),(520.0,40.0)), + ((480.0,80.0),(400.0,0.0)), + ((640.0,120.0),(480.0,80.0)), + ((480.0,160.0),(640.0,160.0)), + ((320.0,0.0),(480.0,160.0)), + ((240.0,40.0),(320.0,0.0)), + ((0.0,0.0),(240.0,40.0))] + +q = Grid 16 16 [((10.0,6.0),(9.0,4.0)), + ((12.0,4.0),(10.0,6.0)), + ((9.0,4.0),(12.0,4.0)), + ((0.0,6.0),(7.0,5.0)), + ((0.0,8.0),(0.0,16.0)), + ((0.0,0.0),(0.0,4.0)), + ((15.0,16.0),(16.0,14.0)), + ((16.0,12.0),(14.0,16.0)), + ((13.0,16.0),(16.0,10.0)), + ((13.0,12.0),(12.0,16.0)), + ((16.0,8.0),(13.0,12.0)), + ((15.0,6.0),(16.0,8.0)), + ((16.0,0.0),(15.0,6.0)), + ((10.0,16.0),(14.0,5.0)), + ((10.0,10.0),(10.0,7.0)), + ((8.0,16.0),(10.0,10.0)), + ((8.0,11.0),(8.0,8.0)), + ((6.0,16.0),(8.0,11.0)), + ((6.0,11.0),(4.0,16.0)), + ((6.0,9.0),(6.0,11.0)), + ((4.0,11.0),(4.0,9.0)), + ((2.0,16.0),(4.0,11.0)), + ((4.0,9.0),(0.0,8.0)), + ((6.0,9.0),(4.0,9.0)), + ((12.0,6.0),(6.0,9.0)), + ((16.0,0.0),(12.0,6.0)), + ((9.0,3.0),(8.0,1.0)), + ((11.0,1.0),(9.0,3.0)), + ((8.0,1.0),(11.0,1.0)), + ((8.0,0.0),(7.0,1.0)), + ((5.0,2.0),(7.0,1.0)), + ((6.0,0.0),(7.0,1.0)), + ((5.0,2.0),(4.0,0.0)), + ((3.0,3.0),(5.0,2.0)), + ((3.0,3.0),(0.0,4.0)), + ((2.0,0.0),(3.0,3.0))] + +r = Grid 32 32 [((32.0,0.0),(24.0,8.0)), + ((32.0,4.0),(30.0,2.0)), + ((28.0,4.0),(32.0,8.0)), + ((32.0,12.0),(26.0,6.0)), + ((24.0,8.0),(32.0,16.0)), + ((22.0,0.0),(24.0,8.0)), + ((22.0,12.0),(12.0,0.0)), + ((32.0,20.0),(22.0,12.0)), + ((24.0,26.0),(10.0,22.0)), + ((32.0,32.0),(24.0,26.0)), + ((16.0,28.0),(24.0,32.0)), + ((6.0,26.0),(16.0,28.0)), + ((16.0,32.0),(4.0,28.0)), + ((2.0,30.0),(8.0,32.0)), + ((0.0,32.0),(16.0,16.0)), + ((0.0,24.0),(10.0,12.0)), + ((4.0,8.0),(0.0,16.0)), + ((28.0,20.0),(32.0,24.0)), + ((16.0,16.0),(28.0,20.0)), + ((4.0,8.0),(16.0,16.0)), + ((2.0,4.0),(4.0,8.0)), + ((2.0,4.0),(0.0,8.0)), + ((0.0,0.0),(2.0,4.0))] + +s = Grid 32 32 [((24.0,0.0),(32.0,0.0)), + ((0.0,0.0),(16.0,0.0)), + ((30.0,14.0),(32.0,12.0)), + ((32.0,8.0),(28.0,10.0)), + ((26.0,6.0),(32.0,4.0)), + ((26.0,6.0),(24.0,0.0)), + ((30.0,14.0),(26.0,6.0)), + ((32.0,16.0),(30.0,14.0)), + ((30.0,16.0),(26.0,18.0)), + ((30.0,22.0),(30.0,16.0)), + ((26.0,18.0),(30.0,22.0)), + ((24.0,24.0),(20.0,20.0)), + ((24.0,18.0),(24.0,24.0)), + ((20.0,20.0),(24.0,18.0)), + ((20.0,0.0),(22.0,12.0)), + ((14.0,6.0),(16.0,0.0)), + ((14.0,16.0),(16.0,20.0)), + ((14.0,6.0),(14.0,16.0)), + ((20.0,24.0),(16.0,20.0)), + ((32.0,32.0),(20.0,24.0)), + ((16.0,28.0),(32.0,32.0)), + ((8.0,28.0),(16.0,28.0)), + ((0.0,32.0),(8.0,28.0)), + ((0.0,24.0),(4.0,30.0)), + ((0.0,20.0),(14.0,24.0)), + ((0.0,16.0),(16.0,20.0)), + ((0.0,12.0),(14.0,16.0)), + ((0.0,8.0),(14.0,12.0)), + ((0.0,4.0),(14.0,6.0))] + +quartet p1 p2 p3 p4 = + Above 1 (Beside 1 p1 1 p2) 1 (Beside 1 p3 1 p4) + +cyc p1 = + quartet p1 (Rot (Rot (Rot p1))) (Rot p1) (Rot (Rot p1)) + +t = quartet p q r s + +u = cyc (Rot q) + +side1 = quartet Nil Nil (Rot t) t + +side2 = quartet side1 side1 (Rot t) t + +corner1 = quartet Nil Nil Nil u + +corner2 = quartet corner1 side1 (Rot side1) u + +pseudocorner = quartet corner2 side2 (Rot side2) (Rot t) + +pseudolimit = cyc pseudocorner + +nonet p1 p2 p3 p4 p5 p6 p7 p8 p9 = + Above 1 (Beside 1 p1 2 (Beside 1 p2 1 p3)) + 2 (Above 1 (Beside 1 p4 2 (Beside 1 p5 1 p6)) + 1 (Beside 1 p7 2 (Beside 1 p8 1 p9))) + +corner = nonet corner2 side2 side2 + (Rot side2) u (Rot t) + (Rot side2) (Rot t) (Rot q) + +squarelimit = cyc corner + +final host = draw host corner ((0,0),(500,0),(0,500)) (0,0,500,500) +skewedfinal host = draw host squarelimit ((0,0),(600,200),(200,600)) (0,0,800,800) + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $ + final host diff --git a/progs/demo/X11/graphics/sqrlmt.hu b/progs/demo/X11/graphics/sqrlmt.hu new file mode 100644 index 0000000..7d46b0e --- /dev/null +++ b/progs/demo/X11/graphics/sqrlmt.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +henderson.hu +sqrlmt.hs diff --git a/progs/demo/X11/graphics/stop.pic b/progs/demo/X11/graphics/stop.pic new file mode 100644 index 0000000..01ed7d6 --- /dev/null +++ b/progs/demo/X11/graphics/stop.pic @@ -0,0 +1 @@ +Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/strange.pic b/progs/demo/X11/graphics/strange.pic new file mode 100644 index 0000000..5484b0b --- /dev/null +++ b/progs/demo/X11/graphics/strange.pic @@ -0,0 +1,2 @@ +Overlay (Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]) (Flip (File "text.pic")) + diff --git a/progs/demo/X11/graphics/text.pic b/progs/demo/X11/graphics/text.pic new file mode 100644 index 0000000..87fd55c --- /dev/null +++ b/progs/demo/X11/graphics/text.pic @@ -0,0 +1 @@ +Grid 200 200 [((177.00000000000000,91.000000000000000),(177.00000000000000,91.000000000000000)), ((172.00000000000000,63.000000000000000),(175.00000000000000,79.000000000000000)), ((164.00000000000000,73.000000000000000),(148.00000000000000,77.000000000000000)), ((159.00000000000000,63.000000000000000),(164.00000000000000,71.000000000000000)), ((148.00000000000000,63.000000000000000),(159.00000000000000,62.000000000000000)), ((146.00000000000000,61.000000000000000),(149.00000000000000,92.000000000000000)), ((122.00000000000000,61.000000000000000),(115.00000000000000,61.000000000000000)), ((130.00000000000000,62.000000000000000),(122.00000000000000,61.000000000000000)), ((133.00000000000000,75.000000000000000),(130.00000000000000,63.000000000000000)), ((124.00000000000000,89.000000000000000),(131.00000000000000,79.000000000000000)), ((111.00000000000000,81.000000000000000),(124.00000000000000,89.000000000000000)), ((114.00000000000000,61.000000000000000),(108.00000000000000,78.000000000000000)), ((88.000000000000000,64.000000000000000),(91.000000000000000,91.000000000000000)), ((73.000000000000000,62.000000000000000),(96.000000000000000,60.000000000000000)), ((65.000000000000000,97.000000000000000),(49.000000000000000,100.00000000000000)), ((61.000000000000000,80.000000000000000),(65.000000000000000,97.000000000000000)), ((46.000000000000000,79.000000000000000),(61.000000000000000,80.000000000000000)), ((45.000000000000000,61.000000000000000),(46.000000000000000,79.000000000000000)), ((61.000000000000000,63.000000000000000),(41.000000000000000,62.000000000000000))]
\ No newline at end of file diff --git a/progs/demo/X11/logo/EXAMPLES.LOGO b/progs/demo/X11/logo/EXAMPLES.LOGO new file mode 100644 index 0000000..bb89632 --- /dev/null +++ b/progs/demo/X11/logo/EXAMPLES.LOGO @@ -0,0 +1,70 @@ +(to nth :index :lst + (if (equal :index 1) + then (first :lst) + else (nth (difference :index 1) (butfirst :lst)))) + +(to makelist :begin :end + (fput :begin (if (equal :begin :end) + then [[]] + else (makelist (sum :begin 1) :end)))) + +(to wheel :centerright + [(hideturtle) + (pendown) + (setangle 90) + (setxy :centerright 350) + (repeat 72 times + [(forward 2) + (left 5)])]) + +(to car + [(pendown) + (hideturtle) + (setxy 400 350) + (setangle 90) + (forward 70) + (left 90) + (forward 100) + (right 60) + (forward 80) + (left 60) + (forward 100) + (left 60) + (forward 80) + (right 60) + (forward 70) + (left 90) + (forward 70) + (left 90) + (forward 350) + (wheel 350) + (wheel 150)]) + +(to docar? + [(local "ans) + (print [do you want a car?]) + (make "ans (read)) + (if (equal (first ans) "yes) + then (car) + else [[oh well]])]) + +(to poly :size :angles + [(hideturtle) + (pendown) + (setangle 90) + (repeat :angles times + [(forward :size) + (right (div 360 :angles))])]) + +(make "x (makelist 3 12)) + +(while (less (first x) 12) + [(make "x (butfirst x)) + (print x)]) + +(clean) + +(car) + +(poly 100 5) + diff --git a/progs/demo/X11/logo/README b/progs/demo/X11/logo/README new file mode 100644 index 0000000..b483e2a --- /dev/null +++ b/progs/demo/X11/logo/README @@ -0,0 +1,104 @@ +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: User Manual + + +Control Commands: + + +(DO <clause> WHILE <cond>) + + Loop, executing a list of commands, then checking a condition and +looping again if the condition is true. + + +(REPEAT n TIMES) + WHILE cn cl + IF cn THEN cl1 [ELSE cl2] + +Load a file: + USE "filename + +Environment Commands: + MAKE "nm v + LOCAL "nm + TO :nm1 :nm2 :nm3 ... cl + +Text I/O: + PRINT v + READ + +Graphics Commands: + FORWARD n + BACKWARD n + SETXY n1 n2 + LEFT n + RIGHT n + PENUP + PENDOWN + HIDETURTLE + SHOWTURTLE + CLEARSCREEN + CLEAN + +Graphics Functions: + XCOR + YCOR + GETANGLE + GETPEN + GETTURTLE + +Mathematical: + SUM n1 n2 + DIFFERENCE n1 n2 + PRODUCT n1 n2 + MOD n1 n2 + DIV n1 n2 + POWER n1 n2 + +Boolean: + AND b1 b2 + OR b1 b2 + NOT b + +Predicates: + WORDP v + LISTP v + NUMBERP v + GREATER n1 n2 + LESS n1 n2 + EQUAL v1 v2 + +Word/List: + FIRST t + LAST t + FPUT t l + BUTFIRST l + WORD w1 w2 w3 ... + LIST t1 t2 t3 ... + CONCAT l1 l2 + SENTENCE t1 t2 t3 ... + + +Our Logo interpreter will only support one of the three windowing +modes: window mode, where the turtle, if it walks off the end of the +screen, just continues going and does not wrap. The two (unsupported) +modes are fence mode where the turtle cannot walk off the end, and +wrap mode. The initial turtle state will be with the turtle hidden, +the pen down, and the turtle in the center of the screen facing +upwards. + +All input (both for commands as well as user-input) will be +case-insensitive, and the interpreter needs to handle lists, words, +integers, and boolean values. Also, typing "GoodBye" at the LOGO> +prompt exits the interpreter. + +All commands will be enclosed in parentheses, and all lists of +commands will be enclosed in square brackets, so that there is no +longer any need for the keyword "End". Also, all procedures will +return the value of their last command, so that there are no Stop or +Output commands. IF statements should return the value of the last +statement executed, but all looping constructs should return no value. + + diff --git a/progs/demo/X11/logo/logo.hs b/progs/demo/X11/logo/logo.hs new file mode 100644 index 0000000..458eca1 --- /dev/null +++ b/progs/demo/X11/logo/logo.hs @@ -0,0 +1,1345 @@ +{- + +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: LOGO Interpreter + +-} + + + +------------------------------------------------------------------------------- +module REPLoop where + +{- + +REPLoop has two main parts: the first part (function logo) sets up the +graphics window, prints a welcome message, initializes the variable +and procedure environments and the turtle, accepts and lines's the +user input, runs the read-eval-print loop (part two), and then closes +the graphics window and exists; the second part (function repLoop) +lexes and parses each command, prints an error message if there was a +syntax error and evaluates (or tries to) if there wasn't, and then +either prints the value or an error message or exits if the value +returnd by the evaluator is "GoodBye". + +-} + +import Lexer +import Parser +import Evaluator +import Xlib + +demo = main + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $ + logo host + +logo :: String -> IO () + +logo host = + xOpenDisplay host `thenIO` \ display -> + + let (screen:_) = xDisplayRoots display + fg_color = xScreenWhitePixel screen + bg_color = xScreenBlackPixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 100 100 500 500) + [XWinBackground bg_color, + XWinBackingStore XAlwaysBackStore] + `thenIO` \ graphWindow -> + xSetWmName graphWindow "Logo" `thenIO` \ () -> + xSetWmIconName graphWindow "Logo" `thenIO` \ () -> + xMapWindow graphWindow `thenIO` \ () -> + + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ graphContext -> + + xDisplayForceOutput display `thenIO` \ () -> + + appendChan stdout ("Welcome to LOGO!\n" ++ prompt) exit $ + readChan stdin exit $ \userInput -> + repLoop + (varEnvsInit,procEnvsInit,turtleInit) + ((lines userInput,Lexer), + (graphWindow,display,graphContext,bg_color,fg_color)) $ + xCloseDisplay display + +-- Initial Environments -- + +varEnvsInit :: VarsType +varEnvsInit = [[("GOODBYE",GoodBye)]] + +-- all user-defined commands must have dummy entries +procEnvsInit :: ProcsType +procEnvsInit = (map (makeFakeProc) + [("XCOR",0),("YCOR",0),("GETANGLE",0),("GETPEN",0), + ("GETTURTLE",0), + ("SUM",2),("DIFFERENCE",2),("PRODUCT",2),("MOD",2), + ("DIV",2),("POWER",2), + ("AND",2),("OR",2),("NOT",1), + ("WORDP",1),("LISTP",1),("NUMBERP",1),("GREATER",2), + ("EQUAL",2),("LESS",2), + ("BUTFIRST",1),("FPUT",2),("CONCAT",2), + ("FIRST",1),("LAST",1),("WORD",-2),("LIST",-2), + ("SENTENCE",-2), ("USE",1)]):[] + +turtleInit :: TurtleType +turtleInit = (500 `div` 2,500 `div` 2,90,True,False) + +-- makes a dummy procedure +makeFakeProc :: (NameType , Int) -> (NameType , ProcType) +makeFakeProc (name,num) = (name,(makeArgs num,[])) + +makeArgs :: Int -> [NameType] +makeArgs n | n > 0 = "" : makeArgs (n-1) + | otherwise = [] + +-- keep running Read-Eval-Print Loop until user types GoodBye +-- repLoop keeps running until user types "GoodBye", alternately +-- lexing, parsing, and evaluating each command +-- after a syntax error, the lex state is reset +repLoop :: EnvsType -> StateType -> IO () -> IO () +repLoop e1 (inS1,gs1) end = + let fail1 msg (is1,ls1) = errorOutput msg $ + repLoop e1 ((is1,Lexer),gs1) end + -- parser fail continuation doesn't contain graphics state + fail2 msg ((is2,ls2),gs2) = errorOutput msg $ + repLoop e1 ((is2,Lexer),gs1) end + -- evaluator fail continuation does contain graphics state + in + parse [] inS1 fail1 $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail2 $ \v e2 ((is3,ls3),gs3) -> + output v end $ + repLoop e2 ((is3,Lexer),gs3) end + else + fail1 "Syntax error: expected end of line" inS2 + -- repLoop will still be rerun + +-- print error message +errorOutput :: String -> IO () -> IO () +errorOutput error = appendChan stdout (error ++ prompt) abort + +-- print expression value, exiting if GoodBye +output :: Value -> IO () -> IO () -> IO () +output GoodBye end succ + = appendChan stdout "\nGoodbye!\n"abort end +output v end succ + = appendChan stdout ((valueToString v) ++ prompt) abort succ + +prompt :: String +prompt = "\nLOGO> " + + + +------------------------------------------------------------------------------- +module Evaluator where + +{- + +Evaluator takes an Abstract Syntax Tree and evaluates it in the +current environment, returning both the resultant value and the new +environment (as well as the updated state, of which only the user +input can actually be changed in the evaluator). + +A value can be of one of six types: integer, string, list, and +boolean, as well as null (for commands which don't return anything and +newly-declared local variables), and goodbye, which allows logo to +quit. + +The environment consists of three parts. The variable environment and +the procedure environment are separate (so that a name can refer both +to a variable and a procedure: Logo syntax is such that there is +never any ambiguity) are both lists of name-value association lists. +Each association list representes a "local environment", with each +successive one being more "global", so that the last environment in +the list is the global environment. Local environments are produced +by user-function invocations and removed at the end of those +invocations. + +-} + +import Lexer +import Parser +import Xlib + +type NameType = [Char] +type WordType = [Char] +type Error = [Char] + +type StateType = (InputState , GraphicsState) +type GraphicsState = (XWindow , XDisplay , XGcontext , XPixel , XPixel) +type EnvsType = (VarsType,ProcsType,TurtleType) +type VarsType = [[(NameType , Value)]] +type ProcsType = [[(NameType , ProcType)]] +type TurtleType = (Int , Int , Int , Bool , Bool) +type ProcType = ([NameType] , ClauseType) + +data Value = Null + | Num Int + | Word WordType + | List ListType + | Boolean Bool + | GoodBye + deriving Text + +data ListType = NullList | Value :* ListType + deriving Text + + +type EvalFailType = Error -> StateType -> IO () +type EvalSuccType = Value -> EnvsType -> StateType -> IO () +type EvalResType = StateType -> EvalFailType -> EvalSuccType -> IO () +type EvaluateType = EnvsType -> AST -> EvalResType + + +evaluate :: EvaluateType + +evaluate (vs,p:ps,ttl) (To newName newProc) ss fail succ + = succ Null (vs,((newName,newProc):p):ps,ttl) ss + -- procedures + +evaluate e (Read) ((i:is,ls),gs) fail succ + = succ (List (makeReadList (lexerReadLine i))) e ((is,ls),gs) + -- user input + +evaluate e1 (Print [a]) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + appendChan stdout ((valueToString v)++"\n") abort $ + succ Null e2 ss2 + -- user output + +evaluate e (Argument (Val (Word n))) ss fail succ + = lookup e n ss fail $ \v -> + succ v e ss + -- variable reference + +evaluate e (Argument (Val v)) ss fail succ + = succ v e ss + -- constant + +evaluate e (Argument (QuotedWordArg n)) ss fail succ + = succ (Word n) e ss + -- string constant + +evaluate (v:vs,ps,ttl) (Local n) ss fail succ + = succ Null (((n,Null):v):vs,ps,ttl) ss + -- local variable declaraion + -- local returns null, and sets the new local variable to null also + +evaluate e (ParseList l) ss fail succ + = succ (List l) e ss + -- lists (also constant) + +evaluate e (Loop l cond insts) ss fail succ + = evalLoop l e cond insts ss fail succ + -- loops + +evaluate e (If cond thens elses) ss fail succ + = evalIf e cond thens elses ss fail succ + -- if-then[-eles] conditionals + +evaluate e1 (Command name as1) ss fail succ + | ((na == length as1) || (na == -2)) + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + apply name as2 e2 ss2 fail $ \v e3 ss3 -> + succ v e3 ss3 + | na == -1 + = fail ("Function does not exist: " ++ name) ss + | otherwise + = fail ("Wrong number of arguments to " ++ name) ss + where na = numArgs e1 name + -- function applications + +evaluate e1 (Make n a) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + update e2 n v $ \e3 -> + succ v e3 ss2 + -- assignment statements, which return the assigned value + +evaluate e1 (Graphics name as1) ss fail succ + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + doGraphics name as2 e2 ss2 fail $ \e3 ss3 -> + succ Null e3 ss3 + -- side-effecting graphics statements, which all return null +-- end evaluate + + +-- evaluate a list of actual parameters, returning the corresponding +-- list of values +evalArgs :: EnvsType -> ParseArgs -> StateType -> EvalFailType -> + (EnvsType -> EvalArgs -> StateType -> IO ()) -> IO () +evalArgs e [] ss fail succ + = succ e [] ss +evalArgs e1 (a:as1) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalArgs e2 as1 ss2 fail $ \e3 as2 ss3 -> + succ e3 (v:as2) ss3 + + +-- evaluate a list of commands, returning the value of the last one +evalClause :: EnvsType -> ClauseType -> EvalResType +evalClause e [] ss fail succ + = succ Null e ss +evalClause e (a:[]) ss fail succ + = evaluate e a ss fail succ +evalClause e1 (a:as) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalClause e2 as ss2 fail succ + +-- convert a lexed user-input list to a list constant +makeReadList :: [WordType] -> ListType +makeReadList [] = NullList +makeReadList (w:ws) = (Word w) :* (makeReadList ws) + + +-- Variable routines -- + +-- look up a variable reference in the variable environment +-- search the most-local environments first +-- return an error if not found +lookup :: EnvsType -> NameType -> StateType -> EvalFailType -> + (Value -> IO ()) -> IO () +lookup ([],ps,ttl) name ss fail succ + = fail ("Unbound variable: " ++ name) ss +lookup ([]:vss,ps,ttl) name ss fail succ + = lookup (vss,ps,ttl) name ss fail succ +lookup (((n,v):vs):vss,ps,ttl) name ss fail succ + | n == name = succ v + | otherwise = lookup (vs:vss,ps,ttl) name ss fail succ + +-- update the variable environment +-- replace the most-local occurrance first; if none are found, +-- create a new variable and place it in the most-global environment +update :: EnvsType -> NameType -> Value -> (EnvsType -> IO ()) -> IO () +update ([]:[],ps,ttl) name value succ + = succ (((name,value):[]):[],ps,ttl) +update ([]:vss,ps,ttl) name value succ + = update (vss,ps,ttl) name value $ \(vss2,ps2,ttl2) -> + succ ([]:vss2,ps2,ttl2) +update (((n,v):vs):vss,ps,ttl) name value succ + | n == name = succ (((n,value):vs):vss,ps,ttl) + | otherwise = update (vs:vss,ps,ttl) name value $ \(vs2:vss2,ps2,ttl2) -> + succ (((n,v):vs2):vss2,ps2,ttl2) + + +-- Control structures -- + +-- evaluate loops +evalLoop :: LoopType -> EnvsType -> ConditionType -> ClauseType -> + EvalResType +evalLoop Do = evalDo +evalLoop While = evalWhile +evalLoop Repeat = evalRepeat + +-- evaluate while statements +-- loop semantics: evaluate condition; if true, evaluate clause, then loop +-- while returns null +evalWhile :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalWhile e1 cond insts ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then + evalClause e2 insts ss2 fail $ \v e3 ss3 -> + evalWhile e3 cond insts ss3 fail succ + else + succ Null e2 ss2 + +-- evaluate do-while statements +-- loop semantics: evaluate clause then evaluate condition; if true, loop +evalDo :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalDo e1 cond insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + evalCond e2 cond ss2 fail $ \b e3 ss3 -> + if b + then + evalDo e3 cond insts ss3 fail succ + else + succ Null e3 ss3 + +-- evaluate repeat statements +-- loop semantics: evaluate loop number as n; evaluate clause n times +-- evaluate loop number and print error if it is negative or not an integer +evalRepeat :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalRepeat e1 cond insts ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Num n -> if (n >= 0) + then doIterations e2 n insts ss2 fail succ + else fail "Repeat: Iteration count cannot be negative" ss2 + otherwise -> fail "Repeat: Invalid iteration count" ss2 + +-- perform loop interations: evaluate "insts" "n" times +doIterations :: EnvsType -> Int -> ClauseType -> EvalResType +doIterations e 0 insts ss fail succ + = succ Null e ss +doIterations e1 (n+1) insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + doIterations e2 n insts ss2 fail succ + +-- evaluates conditions and returns either true, false, or an error +evalCond :: EnvsType -> ConditionType -> StateType -> EvalFailType -> + (Bool -> EnvsType -> StateType -> IO ()) -> IO () +evalCond e1 cond ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Boolean b -> succ b e2 ss2 + otherwise -> fail "Invalid condition" ss2 + +-- evaluate if-then[-else] statements +evalIf :: EnvsType -> ConditionType -> ClauseType -> ClauseType -> EvalResType +evalIf e1 cond thens elses ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then evalClause e2 thens ss2 fail succ + else evalClause e2 elses ss2 fail succ + + +-- Function application -- + +-- returns the number of arguments to a user-defined or built-in function +-- -1 means the function wasn't found +-- -2 means the function can take any number of arguments +numArgs :: EnvsType -> CommandName -> Int +numArgs (vs,[],ttl) name + = -1 +numArgs (vs,[]:pss,ttl) name + = numArgs (vs,pss,ttl) name +numArgs (vs,((n,(formals,body)):ps):pss,ttl) name + | inList ["WORD","SENTENCE","LIST"] name = -2 + | n == name = length formals + | otherwise = numArgs (vs,ps:pss,ttl) name + +-- apply a function to its arguments +-- mostly just decides if it's user-defined or built-in, then dispatches +apply :: CommandName -> EvalArgs -> EnvsType -> EvalResType +apply n as e ss fail succ + | isBuiltIn n = applyPrimProc n as e ss fail succ + | otherwise = applyUserProc (getProc e n) as e ss fail succ + + + +-- returns procedure "name" from the procedure environment +-- searches most-local environments first +-- precondition: procedure does exist somewhere +getProc :: EnvsType -> CommandName -> ProcType +getProc (vss,[]:pss,ttl) name + = getProc (vss,pss,ttl) name +getProc (vs,((n,p):ps):pss,ttl) name + | n == name = p + | otherwise = getProc (vs,ps:pss,ttl) name + +-- apply user function: +-- bind formal parameters +-- create local enviroments +-- evaluate body of function +-- destroy local environments +-- return value of body +applyUserProc :: ProcType -> EvalArgs -> EnvsType -> EvalResType +applyUserProc (formals,body) actuals e1 ss fail succ + = bind formals actuals e1 $ \e2 -> + evalClause e2 body ss fail $ \v (vs:vss,ps:pss,ts) ss2 -> + succ v (vss,pss,ts) ss2 + +-- bind formal parameters to actuals in local environment +bind :: [NameType] -> EvalArgs -> EnvsType -> (EnvsType -> IO ()) -> IO () +bind formals actuals (vss,pss,ttl) succ + = succ ((zip formals actuals):vss,[]:pss,ttl) + + +-- Built-in functions -- + +-- returns true for built-in functions +isBuiltIn :: CommandName -> Bool +isBuiltIn = inList ["XCOR","YCOR","GETANGLE","GETPEN","GETTURTLE", + "SUM","DIFFERENCE","PRODUCT","MOD","DIV","POWER", + "AND","OR","NOT", + "WORDP","LISTP","NUMBERP","GREATER","EQUAL","LESS", + "BUTFIRST","FPUT","CONCAT", + "FIRST","LAST","WORD","LIST","SENTENCE", "USE"] + + +-- applies a built-in function to its arguments +applyPrimProc :: CommandName -> [Value] -> EnvsType -> EvalResType + +applyPrimProc "XCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num x) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "YCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num y) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETANGLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num a) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETPEN" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean p) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean t) (vs,ps,(x,y,a,p,t)) ss + +applyPrimProc "SUM" [Num a , Num b] e ss fail succ + = succ (Num (a+b)) e ss +applyPrimProc "DIFFERENCE" [Num a , Num b] e ss fail succ + = succ (Num (a-b)) e ss +applyPrimProc "PRODUCT" [Num a , Num b] e ss fail succ + = succ (Num (a*b)) e ss +applyPrimProc "MOD" [Num a , Num b] e ss fail succ + = succ (Num (a `mod` b)) e ss +applyPrimProc "DIV" [Num a , Num b] e ss fail succ + = succ (Num (a `div` b)) e ss +applyPrimProc "POWER" [Num a , Num b] e ss fail succ + | b >= 0 = succ (Num (a^b)) e ss + | otherwise = fail ("Negative exponent: " ++ (show b)) ss + +applyPrimProc "AND" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a && b)) e ss +applyPrimProc "OR" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a || b)) e ss +applyPrimProc "NOT" [Boolean a] e ss fail succ + = succ (Boolean (not a)) e ss + +applyPrimProc "WORDP" [Word w] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "WORDP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "NUMBERP" [Num n] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "NUMBERP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "LISTP" [List l] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "LISTP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "GREATER" [Num a , Num b] e ss fail succ + = succ (Boolean (a > b)) e ss +applyPrimProc "EQUAL" [Num a , Num b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Word a , Word b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "LESS" [Num a , Num b] e ss fail succ + = succ (Boolean (a < b)) e ss + +applyPrimProc "BUTFIRST" [Word ""] e ss fail succ + = succ (Word "") e ss +applyPrimProc "BUTFIRST" [Word (c:cs)] e ss fail succ + = succ (Word cs) e ss +applyPrimProc "BUTFIRST" [List NullList] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "BUTFIRST" [List (v :* vs)] e ss fail succ + = succ (List vs) e ss +applyPrimProc "FPUT" [v , List l] e ss fail succ + = succ (List (v :* l)) e ss +applyPrimProc "CONCAT" [List l1 , List l2] e ss fail succ + = succ (List (listConcatenate l1 l2)) e ss +applyPrimProc "FIRST" [Word (c:cs)] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "FIRST" [List (v :* vs)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [Word (c:[])] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "LAST" [Word ""] e ss fail succ + = succ Null e ss +applyPrimProc "LAST" [Word (c:cs)] e ss fail succ + = applyPrimProc "LAST" [(Word cs)] e ss fail succ +applyPrimProc "LAST" [List (v :* NullList)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [List (v :* vs)] e ss fail succ + = applyPrimProc "LAST" [(List vs)] e ss fail succ +applyPrimProc "WORD" [] e ss fail succ + = succ (Word "") e ss +applyPrimProc "WORD" ((Word w):ws) e ss fail succ + = applyPrimProc "WORD" ws e ss fail $ \(Word wsc) e2 ss2 -> + succ (Word (w ++ wsc)) e2 ss2 +applyPrimProc "LIST" (v:vs) e ss fail succ + = applyPrimProc "LIST" vs e ss fail $ \(List l) e2 ss2 -> + succ (List (v :* l)) e2 ss2 +applyPrimProc "LIST" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" ((List l):[]) e ss fail succ + = succ (List l) e ss +applyPrimProc "SENTENCE" ((List l):vs) e ss fail succ + = applyPrimProc "SENTENCE" [List l] e ss fail $ \(List s1) e2 ss2 -> + applyPrimProc "SENTENCE" vs e2 ss2 fail $ \(List s2) e3 ss3 -> + succ (List (listConcatenate s1 s2)) e3 ss3 +applyPrimProc "SENTENCE" (v:vs) e ss fail succ + = applyPrimProc "SENTENCE" vs e ss fail $ \(List ws) e2 ss2 -> + succ (List (v :* ws)) e2 ss2 + +applyPrimProc "USE" [Word filename] + e + ss@((ins, ls), gs) + fail succ + = readFile filename (\ _ -> fail ("Can't read file: " ++ filename) ss) + $ \filecontents -> + useRepLoop e ((lines filecontents, Lexer), gs) + (\ msg s -> fail msg ss) $ \ v e s -> + succ v e ss + +applyPrimProc n _ _ ss fail _ + = fail ("Incorrect arguments: " ++ n) ss + +useRepLoop :: EnvsType -> EvalResType +useRepLoop e s@(([], ls), gs) fail succ = succ (Word "OK") e s +useRepLoop e1 s1@(inS1,gs1) fail succ = + parse [] inS1 (\ msg ins -> fail msg (ins, gs1)) $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail $ \v e2 s3 -> + useRepLoop e2 s3 fail succ + else + fail "Syntax error: expected end of line" (inS2, gs1) + + + +-- concatenates two lists +listConcatenate :: ListType -> ListType -> ListType +listConcatenate NullList l2 = l2 +listConcatenate (v :* l1) l2 = (v :* (listConcatenate l1 l2)) + + +-- Graphics -- + +type EvalArgs = [Value] +type GraphEnv = (Int,Int,Int,Bool) + +-- evaluates side-effecting graphics functions +-- note: none of them return values +doGraphics :: CommandName -> EvalArgs -> EnvsType -> StateType -> + EvalFailType -> (EnvsType -> StateType -> IO ()) -> IO () + +doGraphics "HIDETURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = hideTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,False)) ss + -- hide turtle, appropriately adjust environment + +doGraphics "SHOWTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = showTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,True)) ss + -- show turtle, appropriately adjust environment + +doGraphics name as (vs,ps,(x,y,a,p,True)) ss fail succ + = hideTurtle x y a ss $ + moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + showTurtle x2 y2 a2 ss $ + succ (vs,ps,(x2,y2,a2,p2,True)) ss + -- executes graphics commands if turtle is shownn + +doGraphics name as (vs,ps,(x,y,a,p,False)) ss fail succ + = moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + succ (vs,ps,(x2,y2,a2,p2,False)) ss + -- executes graphics commands if turtle is not shown + +-- converts an integer to a float +toFloat :: Int -> Float +toFloat = fromInteger . toInteger + +newmod a b = let c = a `mod` b + in if (c < 0) then (c + b) else c + +-- shows the turtle, but returns nothing +showTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = let dx1 = round (12 * cos (toFloat a * pi/180)) + dx2 = round (4 * sin (toFloat a * pi/180)) + dy1 = round (12 * sin (toFloat a * pi/180)) + dy2 = round (4 * cos (toFloat a * pi/180)) + in + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDisplayForceOutput display + `thenIO_` + succ + +-- hides the turtle, but returns nothing +hideTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +hideTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = xUpdateGcontext graphContext [XGCForeground bg] + `thenIO_` + (showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) $ + (xUpdateGcontext graphContext [XGCForeground fg] + `thenIO_` + succ)) + +-- performs all graphics commands that don't involve hiding/showing +-- the turtle +moveTurtle :: CommandName -> EvalArgs -> GraphEnv -> StateType -> + (GraphEnv -> IO ()) -> IO () +moveTurtle "SETXY" [Num xp,Num yp] (x,y,a,p) ss succ + = succ (xp,yp,a,p) + +-- move the turtle forward "d" times, drawing a line if pen is down +moveTurtle "FORWARD" [Num d] (x,y,a,p) + (is,(graphWindow,display,graphContext,fg,bg)) succ + = let xp = x + round (toFloat d * cos (toFloat a * pi/180)) + yp = y - round (toFloat d * sin (toFloat a * pi/180)) in + (if p + then (xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint xp yp)) + else returnIO ()) `thenIO` \ () -> + xDisplayForceOutput display `thenIO` \ () -> + succ (xp,yp,a,p) + +-- move the turtle backward "d" pixels, drawing a line if pen is down +moveTurtle "BACKWARD" [Num d] (x,y,a,p) ss succ + = moveTurtle "FORWARD" [Num (-d)] (x,y,a,p) ss succ + +-- rotate turtle to "ap" degrees from facing due east +moveTurtle "SETANGLE" [Num ap] (x,y,a,p) ss succ + = succ (x,y,ap,p) + +-- rotate turtle counterclockwise "ap" degrees +moveTurtle "LEFT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a + ap) `newmod` 360 ,p) + +-- rotate turtle clockwise "ap" degrees +moveTurtle "RIGHT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a - ap) `newmod` 360 ,p) + +-- pick pen up +moveTurtle "PENUP" [] (x,y,a,p) ss succ + = succ (x,y,a,False) + +-- put pen down +moveTurtle "PENDOWN" [] (x,y,a,p) ss succ + = succ (x,y,a,True) + +-- clear screen but don't otherwise alter turtle state +moveTurtle "CLEARSCREEN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (x,y,a,p) + +-- pick pen up and reset turtle +moveTurtle "CLEAN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (500 `div` 2,500 `div` 2,90,True) + +-- do nothing if arguments are incorrect +moveTurtle _ _ e _ succ = succ e + + +-- valueToString, etc. -- + +-- convert a value to a string +valueToString :: Value -> String +valueToString (Word w) = w +valueToString (Num n) = show n +valueToString (Boolean True) = "TRUE" +valueToString (Boolean False) = "FALSE" +valueToString Null = "" +valueToString (List l) = "[" ++ (listToString l) ++ "]" +valueToString GoodBye = "Don't play around with this variable!" + +-- convert a list to a string +listToString :: ListType -> String +listToString NullList = "" +listToString (v :* NullList) = valueToString v +listToString (v :* l) = (valueToString v) ++ " " ++ (listToString l) + + + +------------------------------------------------------------------------------- +module Lexer where + +{- + +Lexer takes as input a line from standard input and returns an ordered +pair containing the translation of that list into tokens as well as +the current state of the lexer (how many parentheses and brackets are +still open). The state is necessary because some commands may take +multiple lines, so a bracket (say) may be left open on one line to be +closed later on. + +All unmatched close brackets and parentheses are treated as spaces +(and therefore ignored). + +The method for tokenizing commands is: + + All words are delimited by spaces, parenthesis, or brackets. + + All words beginning with a double quote are returned as quoted words + rather than normal words. + + Any character preceded by a backslash is taken as is, rather than + tokenized normally. + + All words are translated to upper case.. + +The method for tokenizing user input is: + + All words are delimited by spaces and translated to upper case. + +-} + +import Parser +import Evaluator + + +data LexState = Lexer | LexerBracket Int LexState | LexerParen Int LexState + deriving Text + +type LexerType = [Char] -> ([Token] , LexState) + +data Token = OpenBracket + | CloseBracket + | OpenParen + | CloseParen + | QuotedWord WordType + | Normal WordType deriving (Text,Eq) + + +-- call appropriate lex procedure depending upon the current lex state +lexDispatch :: LexState -> LexerType +lexDispatch (Lexer) = lexer +lexDispatch (LexerBracket n s) = lexerBracket n s +lexDispatch (LexerParen n s) = lexerParen n s + + +-- handle commands +lexer :: LexerType +lexer [] = ([] , Lexer) +lexer (' ':cs) = lexer cs +lexer ('[':cs) = let (ts , s) = lexerBracket 1 (Lexer) cs + in (OpenBracket : ts , s) +lexer ('(':cs) = let (ts , s) = lexerParen 1 (Lexer) cs + in (OpenParen : ts , s) +lexer (')':cs) = lexer cs +lexer (']':cs) = lexer cs +lexer ('"':cs) = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((QuotedWord (upWord t)):ts , s) +lexer cs = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((Normal (upWord t)):ts , s) + +lexerWord :: (Char -> Bool) -> [Char] -> (WordType , [Char]) +lexerWord endCond [] + = ([] , []) +lexerWord endCond (c:cs) + | c == '\\' = if cs == [] + then ("\\" , cs) + else + let (t , cs2) = lexerWord endCond (tail cs) + in ((head cs):t , cs2) + | endCond c = ([] , (c:cs)) + | otherwise = let (t , cs2) = lexerWord endCond cs + in ((toUpper c):t , cs2) + + +-- performs lexing inside brackets +lexerBracket :: Int -> LexState -> LexerType +lexerBracket n s [] + = ([] , LexerBracket n s) +lexerBracket n s (' ':cs) + = lexerBracket n s cs +lexerBracket 1 s (']':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseBracket:ts , s2) +lexerBracket n s (']':cs) + = let (ts , s2) = lexerBracket (n-1) s cs + in (CloseBracket:ts , s2) +lexerBracket n s ('[':cs) + = let (ts , s2) = lexerBracket (n+1) s cs + in (OpenBracket:ts , s2) +lexerBracket n s ('(':cs) + = let (ts , s2) = lexerParen 1 (LexerBracket n s) cs + in (OpenParen:ts , s2) +lexerBracket n s (')':cs) + = lexerBracket n s cs +lexerBracket n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerBracket n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- performs lexing inside parentheses +lexerParen :: Int -> LexState -> LexerType +lexerParen n s [] + = ([] , LexerParen n s) +lexerParen n s (' ':cs) + = lexerParen n s cs +lexerParen 1 s (')':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseParen:ts , s2) +lexerParen n s (')':cs) + = let (ts , s2) = lexerParen (n-1) s cs + in (CloseParen:ts , s2) +lexerParen n s ('(':cs) + = let (ts , s2) = lexerParen (n+1) s cs + in (OpenParen:ts , s2) +lexerParen n s ('[':cs) + = let (ts , s2) = lexerBracket 1 (LexerParen n s) cs + in (OpenBracket:ts , s2) +lexerParen n s (']':cs) + = lexerParen n s cs +lexerParen n s ('"':cs) + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((QuotedWord (upWord t)):ts , s2) +lexerParen n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- returns true for delimiters +isDelimiter :: Char -> Bool +isDelimiter = inList " []()" + +-- returns true of p is in cs +inList :: (Eq a) => [a] -> a -> Bool +inList [] p = False +inList (c:cs) p = (c == p) || (inList cs p) + + +-- handle user input +lexerReadLine :: [Char] -> [WordType] +lexerReadLine [] + = [] +lexerReadLine (' ':cs) + = lexerReadLine cs +lexerReadLine cs + = let (firstWord,restOfWords) = span (/= ' ') cs + in (upWord firstWord) : lexerReadLine restOfWords + +-- translate a word to upper case +upWord :: WordType -> WordType +upWord = map (toUpper) + + + +------------------------------------------------------------------------------- +module Parser where + +{- + +Parser takes a list of tokens, the input state, and fail and success +continuations and returns an Abstract Syntax Tree, the remaining +tokens (hopefully none), and the new input state. The input state +will be changed every time Parser runs out of tokens: it simply grabs +(and lexes) the next line of user-input. It therefore doesn't return +anything until the entire AST has been be read in, even if it spans +several lines, though parse may catch some errors before all lines +have been input. In this case, it ceases taking input and returns the +error. + +An Abstract Syntax Tree represents one command, and breaks those +commands into Ifs, Loops, Tos, Locals, Makes, Reads, Prints, +Constants, List constants, Graphics commands (which produce +side-effects), and function applications. All built-in commands that +don't fit into one of those categories are lumped into function +applications along with user-defined functions. Each type of AST is +parsed into subcommands, subclauses (lists of commands), command +arguments (also subcommands), and any other values that will be +immediately-evaluatable (such as function names). + +-} + + +import Lexer +import Evaluator + + +type CommandName = [Char] +type ClauseType = [AST] +type ConditionType = AST + +type ParseArgs = [AST] + +data ArgType = Val Value | QuotedWordArg WordType + deriving Text + +data AST = ParseList ListType + | If ConditionType ClauseType ClauseType + | Loop LoopType ConditionType ClauseType + | To NameType ProcType + | Make NameType AST + | Local NameType + | Read + | Print ParseArgs + | Argument ArgType + | Graphics CommandName ParseArgs + | Command CommandName ParseArgs deriving Text + +data LoopType = Do | While | Repeat + deriving Text + +type ParseFailType = Error -> InputState -> IO () +type ParseType = [Token] -> InputState -> ParseFailType -> + (AST -> [Token] -> InputState -> IO ()) -> IO () +type ParseClauseType = [Token] -> InputState -> ParseFailType -> + (ClauseType -> [Token] -> InputState -> IO ()) -> IO () + +type InputState = ([[Char]] , LexState) + +parse :: ParseType + +parse [] (i:is , ls) fail succ + = let (ts , ls2) = lexDispatch ls i + in parse ts (is , ls2) fail succ + +parse ((QuotedWord s) : ts) inS fail succ + = succ (Argument (QuotedWordArg s)) ts inS + +parse ((Normal s) : ts) inS fail succ + = succ (Argument (Val (process s))) ts inS + +parse (OpenParen : []) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parse (OpenParen:ts) (is,ls2) fail succ + +parse (OpenParen : (Normal t) : ts) inS fail succ + | t == "TO" = makeProc ts inS fail succ + | t == "MAKE" = makeMake ts inS fail succ + | t == "LOCAL" = makeLocal ts inS fail succ + | t == "READ" = makeRead ts inS fail succ + | t == "PRINT" = makePrint ts inS fail succ + | t == "IF" = makeIf ts inS fail succ + | isLoop t = makeLoop t ts inS fail succ + | isGraphics t = makeGraphics t ts inS fail succ + | otherwise = makeCommand t ts inS fail succ + +parse (OpenBracket : ts) inS fail succ + = parseList ts inS fail succ + +parse ts inS@([], _) _ succ = succ (Argument (Val (Word "GOODBYE"))) ts inS + +parse _ inS fail _ + = fail "Syntax error" inS + + +-- returns true for all loop names +isLoop :: CommandName -> Bool +isLoop = inList ["DO","WHILE","REPEAT"] + +-- returns true for all side-effecting graphics command names +isGraphics :: CommandName -> Bool +isGraphics = inList ["FORWARD","BACKWARD","LEFT","RIGHT", + "SETXY","SETANGLE","PENUP","PENDOWN", + "HIDETURTLE","SHOWTURTLE","CLEARSCREEN","CLEAN"] + +-- Parse lists -- + +-- parses a list constant +parseList :: ParseType +parseList [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseList ts (is,ls2) fail succ +parseList (CloseBracket:ts) inS fail succ + = succ (ParseList NullList) ts inS +parseList (OpenBracket:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l1) ts2 inS2 -> + parseList ts2 inS2 fail $ \(ParseList l2) ts3 inS3 -> + succ (ParseList ((List l1) :* l2)) ts3 inS3 +parseList ((Normal w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((process w) :* l)) ts2 inS2 +parseList (OpenParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word "(") :* l)) ts2 inS2 +parseList (CloseParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word ")") :* l)) ts2 inS2 +parseList ((QuotedWord w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word w) :* l)) ts2 inS2 + + +-- parses constant values, distinguishing words from integers and booleans +process :: WordType -> Value +process "TRUE" = Boolean True +process "FALSE" = Boolean False +process ('-':w) + | all isDigit w = Num (- (stringToNum (reverse w))) + | otherwise = Word ('-':w) +process w + | all isDigit w = Num (stringToNum (reverse w)) + | otherwise = Word w + +-- converts a string to a positive integer +stringToNum :: String -> Int +stringToNum (d:[]) = charToDigit d +stringToNum (d:ds) = (charToDigit d) + 10 * stringToNum ds + +-- converts a character to a digit +charToDigit :: Char -> Int +charToDigit c = ord c - ord '0' + + +-- Parse command statements -- + +-- parses commands +-- format: (<name> <arg1> <arg2> ...) +makeCommand :: CommandName -> ParseType +makeCommand n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Command n as) ts2 inS2 + + +-- parses a list of commands that are terminated by token "term"" +parseArgs :: Token -> ParseClauseType +parseArgs term [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseArgs term ts (is,ls2) fail succ +parseArgs term (t:ts) inS fail succ + | t == term = succ [] ts inS + | otherwise = parse (t:ts) inS fail $ \a ts2 inS2 -> + parseArgs term ts2 inS2 fail $ \as ts3 inS3 -> + succ (a:as) ts3 inS3 + + +-- Parse I/O statements -- + +-- parses read statements +-- format: (READ) +makeRead :: ParseType +makeRead (CloseParen:ts) inS fail succ + = succ Read ts inS +makeRead _ inS fail _ + = fail "Read: too many arguments" inS + +-- parses print statements +-- format: (PRINT <arg1>) +makePrint :: ParseType +makePrint ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + if (length as) == 1 + then succ (Print as) ts2 inS2 + else fail "Print: too many arguments" inS + + + +-- Parse TO statements -- + + +-- parses to statements +-- format: (TO <name> <fpname1> <fpname2> ... <clause>) +-- note: all formal parameter names must begin with a colon +makeProc :: ParseType +makeProc [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeProc ts (is,ls2) fail succ +makeProc ((Normal t):ts) inS fail succ + = parseFormals ts inS fail $ \p ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (To t p) ts3 inS3 +makeProc _ inS fail _ + = fail "Invalid procedure name" inS + +-- parses the formal parameters +-- takes all words beginning with a colon, and assumes everything +-- after that is part of the body +parseFormals :: [Token] -> InputState -> ParseFailType -> + (([NameType] , ClauseType) -> [Token] -> InputState -> IO ()) + -> IO () +parseFormals [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseFormals ts (is,ls2) fail succ +parseFormals (OpenBracket:ts) inS fail succ + = parseClause (OpenBracket:ts) inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 +parseFormals ((Normal (':':c:cs)):ts) inS fail succ + = parseFormals ts inS fail $ \(formals,pb) ts2 inS2 -> + succ ((':':c:cs):formals , pb) ts2 inS2 +parseFormals ts inS fail succ + = parseClause ts inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 + + +-- Parse MAKE statements -- + +-- parses make statements +-- format: (MAKE <name> <arg>) +-- note: <name> must be quoted +makeMake :: ParseType +makeMake [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeMake ts (is,ls2) fail succ +makeMake ((QuotedWord s):ts) inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (Make s a) ts3 inS3 +makeMake _ inS fail _ + = fail "Make: Improper variable name" inS + + +-- Parse LOCAL statements -- + +-- parses local statements +-- format: (LOCAL <name>) +-- note: <name> must be quoted +makeLocal :: ParseType +makeLocal [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal ts (is,ls2) fail succ +makeLocal (t:[]) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal (t:ts) (is,ls2) fail succ +makeLocal ((QuotedWord s):CloseParen:ts) inS fail succ + = succ (Local s) ts inS +makeLocal _ inS fail _ + = fail "Local: improper variable name" inS + + +-- Parse IF statements -- + +-- parses if-then and if-then-else statements +-- format: (IF <cond> then <clause> [else <clause>]) +makeIf :: ParseType +makeIf [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeIf ts (is,ls2) fail succ +makeIf ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseThen ts2 inS2 fail $ \thens elses ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (If cond thens elses) ts4 inS4 + + +-- parses then clauses +parseThen :: [Token] -> InputState -> ParseFailType -> + (ClauseType -> ClauseType -> [Token] -> InputState -> IO ()) -> + IO () +parseThen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseThen ts (is,ls2) fail succ +parseThen ((Normal "THEN"):ts) inS fail succ + = parseClause ts inS fail $ \thens ts2 inS2 -> + parseElse ts2 inS2 fail $ \elses ts3 inS3 -> + succ thens elses ts3 inS3 +parseThen _ inS fail _ + = fail "IF: improper THEN clause" inS + +-- parses (optional) else clauses +parseElse :: ParseClauseType +parseElse [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseElse ts (is,ls2) fail succ +parseElse (CloseParen:ts) inS fail succ + = succ [] (CloseParen:ts) inS +parseElse ((Normal "ELSE"):ts) inS fail succ + = parseClause ts inS fail succ +parseElse _ inS fail _ + = fail "IF: improper ELSE clause" inS + +-- parses clauses +-- a clause is either a list of commands enclosed in brackets, or a +-- single command +parseClause :: ParseClauseType +parseClause [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseClause ts (is,ls2) fail succ +parseClause (OpenBracket:ts) inS fail succ + = parseArgs CloseBracket ts inS fail succ +parseClause ts inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + succ [a] ts2 inS2 + + +-- Parse Loop Statements -- + +-- parses loop statements +-- basically a dispatcher for other parse functions +makeLoop :: NameType -> ParseType +makeLoop "DO" = makeDo +makeLoop "WHILE" = makeWhile +makeLoop "REPEAT" = makeRepeat + +-- parses do statements +-- format: (DO <clause> WHILE <cond>) +makeDo :: ParseType +makeDo ts inS fail succ + = parseClause ts inS fail $ \insts ts2 inS2 -> + parseWhileCond ts2 inS2 fail $ \cond ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Do cond insts) ts4 inS4 + +-- parses while conditions (both in while and do-while loops) +-- a condition is simply a command that (hopefully) returns a boolean +parseWhileCond :: ParseType +parseWhileCond [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseWhileCond ts (is,ls2) fail succ +parseWhileCond ((Normal "WHILE"):ts) inS fail succ + = parse ts inS fail succ + +-- parses while statements +-- format: (WHILE <cond> <clause>) +makeWhile :: ParseType +makeWhile ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseClause ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop While cond insts) ts4 inS4 + +-- parses repeat statements +-- format: (REPEAT <num> TIMES <clause>) +-- note: <num> is simply a command that (hopefully) returns an integer +makeRepeat :: ParseType +makeRepeat ts inS fail succ + = parse ts inS fail $ \num ts2 inS2 -> + parseRepeatBody ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Repeat num insts) ts4 inS4 + +-- parses repeat body (just a clause) +parseRepeatBody :: ParseClauseType +parseRepeatBody [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseRepeatBody ts (is,ls2) fail succ +parseRepeatBody ((Normal "TIMES"):ts) inS fail succ + = parseClause ts inS fail succ +parseRepeatBody _ inS fail _ + = fail "Repeat: invalid format" inS + + +-- Parse Graphics Statements -- + +-- parses all side-effecting graphics statements +makeGraphics :: CommandName -> ParseType +makeGraphics n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Graphics n as) ts2 inS2 + +-- Parse Trailing Parenthesis -- + +-- parses the closing paren terminating most commands +getParen :: [Token] -> InputState -> ParseFailType -> + ([Token] -> InputState -> IO ()) -> IO () +getParen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in getParen ts (is,ls) fail succ +getParen (CloseParen:ts) inS fail succ + = succ ts inS +getParen _ inS fail _ + = fail "Expected )" inS + diff --git a/progs/demo/X11/logo/logo.hu b/progs/demo/X11/logo/logo.hu new file mode 100644 index 0000000..388e926 --- /dev/null +++ b/progs/demo/X11/logo/logo.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +logo.hs diff --git a/progs/demo/X11/mdraw/README b/progs/demo/X11/mdraw/README new file mode 100644 index 0000000..c78f7d9 --- /dev/null +++ b/progs/demo/X11/mdraw/README @@ -0,0 +1 @@ +This is a multiple screen version of the draw program. diff --git a/progs/demo/X11/mdraw/mdraw.hs b/progs/demo/X11/mdraw/mdraw.hs new file mode 100644 index 0000000..c4bb508 --- /dev/null +++ b/progs/demo/X11/mdraw/mdraw.hs @@ -0,0 +1,83 @@ +module MDraw where + +import Xlib + +mapIO :: (a -> IO b) -> [a] -> IO [b] + +mapIO f [] = returnIO [] +mapIO f (x:xs) = f x `thenIO` \ y -> + mapIO f xs `thenIO` \ ys -> + returnIO (y:ys) + +map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c] + +map2IO f [] [] = returnIO [] +map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y -> + map2IO f xs zs `thenIO` \ ys -> + returnIO (y:ys) + +xGetEventMul :: XMArray XDisplay -> IO (Int, XEvent) +xGetEventMul displays = + let n_displays = xMArrayLength displays + loop :: Int -> IO (Int, XEvent) + loop i = if i == n_displays then loop 0 + else xMArrayLookup displays i `thenIO` \ display -> + xDisplayForceOutput display `thenIO` \ _ -> + xEventListen display `thenIO` \ n_events -> + if n_events == 0 then loop (i + 1) + else xGetEvent display `thenIO` \ event -> + returnIO (i, event) + in loop 0 + +-- takes a list of host names + +mdraw :: [String] -> IO () +mdraw hosts = + xHandleError (\ (XError msg) -> appendChan stdout msg exit done) $ + mapIO xOpenDisplay hosts `thenIO` \ displays -> + let screens = map (head . xDisplayRoots) displays + fg_colors = map xScreenBlackPixel screens + bg_colors = map xScreenWhitePixel screens + roots = map xScreenRoot screens + in + map2IO (\ root color -> + xCreateWindow root + (XRect 100 100 400 400) + [XWinBackground color, + XWinEventMask (XEventMask [XButtonMotion, + XButtonPress])]) + roots + bg_colors + `thenIO` \windows -> + mapIO xMapWindow windows `thenIO` \ _ -> + map2IO xCreateGcontext + (map XDrawWindow roots) + (map (\ color -> [XGCForeground color]) fg_colors) + `thenIO` \ gcontexts -> + xMArrayCreate displays `thenIO` \ displayArr -> + let + handleEvent lasts = + xGetEventMul displayArr `thenIO` \ (idx, event) -> + let pos = xEventPos event + in + case (xEventType event) of + XButtonPressEvent -> + xMArrayUpdate lasts idx pos `thenIO` \ () -> + handleEvent lasts + XMotionNotifyEvent -> + xMArrayLookup lasts idx `thenIO` \ last -> + map2IO (\ window gcontext -> xDrawLine (XDrawWindow window) + gcontext + last + pos) + windows + gcontexts + `thenIO` \ _ -> + xMArrayUpdate lasts idx pos `thenIO` \ () -> + handleEvent lasts + _ -> handleEvent lasts + in + xMArrayCreate (map (\ _ -> XPoint 0 0) hosts) `thenIO` \ lasts -> + handleEvent lasts `thenIO` \ _ -> + returnIO () + diff --git a/progs/demo/X11/mdraw/mdraw.hu b/progs/demo/X11/mdraw/mdraw.hu new file mode 100644 index 0000000..16296d5 --- /dev/null +++ b/progs/demo/X11/mdraw/mdraw.hu @@ -0,0 +1,3 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +mdraw.hs diff --git a/progs/demo/X11/mdraw/t.hs b/progs/demo/X11/mdraw/t.hs new file mode 100644 index 0000000..77f2baf --- /dev/null +++ b/progs/demo/X11/mdraw/t.hs @@ -0,0 +1,16 @@ +module Test where +import Xlib + +xGetEventMul :: XMArray XDisplay -> IO (Int, XEvent) +xGetEventMul displays = + let n_displays = xMArrayLength displays + loop :: Int -> IO (Int, XEvent) + loop i = if i == n_displays then loop 0 + else xMArrayLookup displays i `thenIO` \ display -> + xDisplayForceOutput display `thenIO` \ _ -> + xEventListen display `thenIO` \ n_events -> + if n_events == 0 then loop (i + 1) + else xGetEvent display `thenIO` \ event -> + returnIO (i, event) + in loop 0 + diff --git a/progs/demo/X11/mdraw/t.hu b/progs/demo/X11/mdraw/t.hu new file mode 100644 index 0000000..657234c --- /dev/null +++ b/progs/demo/X11/mdraw/t.hu @@ -0,0 +1,3 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +t.hs |