diff options
Diffstat (limited to 'progs')
165 files changed, 17571 insertions, 0 deletions
diff --git a/progs/README b/progs/README new file mode 100644 index 0000000..8b28d8f --- /dev/null +++ b/progs/README @@ -0,0 +1,9 @@ +This directory contains Haskell source code. +Subdirectories: +prelude The prelude used in this system +tutorial The online supplement to the Hudak & Fasel tutorial +demo A set of random demo programs +lib Various random extensions + +Other programs can be found in the Haskell program library on the +official Haskell ftp sites. diff --git a/progs/demo/Calendar.hs b/progs/demo/Calendar.hs new file mode 100644 index 0000000..fa2e4a4 --- /dev/null +++ b/progs/demo/Calendar.hs @@ -0,0 +1,138 @@ +-- This is a modification of the calendar program described in section 4.5 +-- of Bird and Wadler's ``Introduction to functional programming'', with +-- two ways of printing the calendar ... as in B+W, or like UNIX `cal': +-- +-- Use from within Yale Haskell: +-- +-- Main> :l Calendar +-- Now in module Calendar. +-- Calendar> @ do cal 1992 +-- Calendar> :e +-- +-- ... Unix style calendar ... +-- +-- Calendar> @ do calendar 1992 +-- Calendar> :e +-- +-- ... Bird and Wadler style calendar ... +-- +-- Calendar> + +module Calendar(cal,calendar) where + +infixr 5 `above`, `beside` + +do cal year = appendChan stdout (cal year) exit done + +-- Picture handling: + +type Picture = [[Char]] + +height, width :: Picture -> Int +height p = length p +width p = length (head p) + +above, beside :: Picture -> Picture -> Picture +above = (++) +beside = zipWith (++) + +stack, spread :: [Picture] -> Picture +stack = foldr1 above +spread = foldr1 beside + +empty :: (Int,Int) -> Picture +empty (h,w) = copy h (copy w ' ') + +block, blockT :: Int -> [Picture] -> Picture +block n = stack . map spread . group n +blockT n = spread . map stack . group n + +group :: Int -> [a] -> [[a]] +group n [] = [] +group n xs = take n xs : group n (drop n xs) + +lframe :: (Int,Int) -> Picture -> Picture +lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n) + where h = height p + w = width p + +-- Information about the months in a year: + +monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31] + where feb | leap year = 29 + | otherwise = 28 + +leap year = if year`mod`100 == 0 then year`mod`400 == 0 + else year`mod`4 == 0 + +monthNames = ["January","February","March","April", + "May","June","July","August", + "September","October","November","December"] + +jan1st year = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7 + where last = year - 1 + +firstDays year = take 12 + (map (`mod`7) + (scanl (+) (jan1st year) (monthLengths year))) + +-- Producing the information necessary for one month: + +dates fd ml = map (date ml) [1-fd..42-fd] + where date ml d | d<1 || ml<d = [" "] + | otherwise = [rjustify 3 (show d)] + +-- The original B+W calendar: + +calendar :: Int -> String +calendar = unlines . block 3 . map picture . months + where picture (mn,yr,fd,ml) = title mn yr `above` table fd ml + title mn yr = lframe (2,25) [mn ++ " " ++ show yr] + table fd ml = lframe (8,25) + (daynames `beside` entries fd ml) + daynames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"] + entries fd ml = blockT 7 (dates fd ml) + months year = zip4 monthNames + (copy 12 year) + (firstDays year) + (monthLengths year) + +-- In a format somewhat closer to UNIX cal: + +cal :: Int -> String +cal year = unlines (banner year `above` body year) + where banner yr = [cjustify 75 (show yr)] `above` empty (1,75) + body = block 3 . map (pad . pic) . months + pic (mn,fd,ml) = title mn `above` table fd ml + pad p = (side`beside`p`beside`side)`above`end + side = empty (8,2) + end = empty (1,25) + title mn = [cjustify 21 mn] + table fd ml = daynames `above` entries fd ml + daynames = [" Su Mo Tu We Th Fr Sa"] + entries fd ml = block 7 (dates fd ml) + months year = zip3 monthNames + (firstDays year) + (monthLengths year) + +-- Additional (B+W)-isms: these really ought to go in a separate module, +-- in a spearate file. But for ease of packaging this simple application, +-- it doesn't seem worth the trouble! + +copy :: Int -> a -> [a] +copy n x = take n (repeat x) + +space :: Int -> String +space n = copy n ' ' + +-- Simple string formatting: + +cjustify, ljustify, rjustify :: Int -> String -> String + +cjustify n s = space halfm ++ s ++ space (m - halfm) + where m = n - length s + halfm = m `div` 2 +ljustify n s = s ++ space (n - length s) +rjustify n s = space (n - length s) ++ s + +-- End of calendar program diff --git a/progs/demo/README b/progs/demo/README new file mode 100644 index 0000000..4a683cd --- /dev/null +++ b/progs/demo/README @@ -0,0 +1,15 @@ + +This directory contains Haskell demo programs. All of these programs +compile and execute properly. + +This directory contains: + + +fact.hs factorial +merge.hs merge sort +pfac.hs parallel factorial +primes.hs prime number generator +qs.hs quick sort +queens.hs N queens +symalg/ A symbolic algebra program +prolog/ A prolog interpreter 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 diff --git a/progs/demo/add.hs b/progs/demo/add.hs new file mode 100644 index 0000000..bdfcc2f --- /dev/null +++ b/progs/demo/add.hs @@ -0,0 +1,21 @@ +-- this is an interactive program to read in two numbers and print their sum. + +module Main where + +main = readChan stdin abort $ \userInput -> + let inputLines = lines userInput in + readInt "Enter first number: " inputLines $ \num1 inputLines1 -> + readInt "Enter second number: " inputLines1 $ \ num2 _ -> + appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done + +readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue + +readInt prompt inputLines succ = + appendChan stdout prompt abort $ + case inputLines of + (l1 : rest) -> case (reads l1) of + [(x,"")] -> succ x rest + _ -> appendChan stdout + "Error - retype the number\n" abort $ + readInt prompt rest succ + _ -> appendChan stdout "Early EOF" abort done diff --git a/progs/demo/eliza.hs b/progs/demo/eliza.hs new file mode 100644 index 0000000..d7bf975 --- /dev/null +++ b/progs/demo/eliza.hs @@ -0,0 +1,267 @@ +-- Eliza: an implementation of the classic pseudo-psychoanalyst --------------- +-- +-- Gofer version by Mark P. Jones, January 12 1992 +-- +-- Adapted from a pascal implementation provided as part of an experimental +-- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original +-- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu). +------------------------------------------------------------------------------- + +import Prelude hiding (conjugate) + +main :: Dialogue +main = interact (("\n\ + \Hi! I'm Eliza. I am your personal therapy computer.\n\ + \Please tell me your problem.\n\ + \\n" ++) + . session initial [] + . filter (not.null) + . map (words . trim) + . lines) + +trim :: String -> String -- strip punctuation characters +trim = foldr cons "" . dropWhile (`elem` punct) + where x `cons` xs | x `elem` punct && null xs = [] + | otherwise = x : xs + punct = [' ', '.', '!', '?', ','] + +-- Read a line at a time, and produce some kind of response ------------------- + +session :: State -> Words -> [Words] -> String +session rs prev [] = [] +session rs prev (l:ls) = response ++ "\n\n" ++ session rs' l ls + where (response, rs') | prev == l = repeated rs + | otherwise = answer rs l + +answer :: State -> Words -> (String, State) +answer st l = (response, newKeyTab kt st) + where (response, kt) = ans (keyTabOf st) + e `cons` (r, es) = (r, e:es) + ans (e:es) | null rs = e `cons` ans es + | otherwise = (makeResponse a (head rs), (key,as):es) + where rs = replies key l + (key,(a:as)) = e + +-- Find all possible replies (without leading string for given key ------------ + +replies :: Words -> Words -> [String] +replies key l = ( map (conjugate l . drop (length key)) + . filter (prefix key . map ucase) + . tails) l + +prefix :: Eq a => [a] -> [a] -> Bool +[] `prefix` xs = True +(x:xs) `prefix` [] = False +(x:xs) `prefix` (y:ys) = x==y && (xs `prefix` ys) + +tails :: [a] -> [[a]] -- non-empty tails of list +tails [] = [] +tails xs = xs : tails (tail xs) + +ucase :: String -> String -- map string to upper case +ucase = map toUpper + +-- Replace keywords in a list of words with appropriate conjugations ---------- + +conjugate :: Words -> Words -> String +conjugate d = unwords . trailingI . map conj . maybe d -- d is default input + where maybe d xs = if null xs then d else xs + conj w = head ([m | (w',m)<-conjugates, uw==w'] ++ [w]) + where uw = ucase w + trailingI = foldr cons [] + where x `cons` xs | x=="I" && null xs = ["me"] + | otherwise = x:xs + +conjugates :: [(Word, Word)] +conjugates = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways]) + where oneways = [ ("me", "you") ] + bothways = [ ("are", "am"), ("we're", "was"), + ("you", "I"), ("your", "my"), + ("I've", "you've"), ("I'm", "you're") ] + prepare = map (\(w,r) -> (ucase w, r)) + +-- Response data -------------------------------------------------------------- + +type Word = String +type Words = [Word] +type KeyTable = [(Key, Replies)] +type Replies = [String] +type State = (KeyTable, Replies) +type Key = Words + +repeated :: State -> (String, State) +repeated (kt, (r:rp)) = (r, (kt, rp)) + +newKeyTab :: KeyTable -> State -> State +newKeyTab kt' (kt, rp) = (kt', rp) + +keyTabOf :: State -> KeyTable +keyTabOf (kt, rp) = kt + +makeResponse :: String -> String -> String +makeResponse ('?':cs) us = cs ++ " " ++ us ++ "?" +makeResponse ('.':cs) us = cs ++ " " ++ us ++ "." +makeResponse cs us = cs + +initial :: State +initial = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs) + +respMsgs = [ ("CAN YOU", canYou), + ("CAN I", canI), + ("YOU ARE", youAre), + ("YOU'RE", youAre), + ("I DON'T", iDont), + ("I FEEL", iFeel), + ("WHY DON'T YOU", whyDont), + ("WHY CAN'T I", whyCant), + ("ARE YOU", areYou), + ("I CAN'T", iCant), + ("I AM", iAm), + ("I'M", iAm), + ("YOU", you), + ("YES", yes), + ("NO", no), + ("COMPUTER", computer), + ("COMPUTERS", computer), + ("I WANT", iWant), + ("WHAT", question), + ("HOW", question), + ("WHO", question), + ("WHERE", question), + ("WHEN", question), + ("WHY", question), + ("NAME", name), + ("BECAUSE", because), + ("CAUSE", because), + ("SORRY", sorry), + ("DREAM", dream), + ("DREAMS", dream), + ("HI", hello), + ("HELLO", hello), + ("MAYBE", maybe), + ("YOUR", your), + ("ALWAYS", always), + ("THINK", think), + ("ALIKE", alike), + ("FRIEND", friend), + ("FRIENDS", friend), + ("", nokeyMsgs) ] + +canYou = [ "?Don't you believe that I can", + "?Perhaps you would like to be able to", + "?You want me to be able to" ] +canI = [ "?Perhaps you don't want to", + "?Do you want to be able to" ] +youAre = [ "?What makes you think I am", + "?Does it please you to believe I am", + "?Perhaps you would like to be", + "?Do you sometimes wish you were" ] +iDont = [ "?Don't you really", + "?Why don't you", + "?Do you wish to be able to", + "Does that trouble you?" ] +iFeel = [ "Tell me more about such feelings.", + "?Do you often feel", + "?Do you enjoy feeling" ] +whyDont = [ "?Do you really believe I don't", + ".Perhaps in good time I will", + "?Do you want me to" ] +whyCant = [ "?Do you think you should be able to", + "?Why can't you" ] +areYou = [ "?Why are you interested in whether or not I am", + "?Would you prefer if I were not", + "?Perhaps in your fantasies I am" ] +iCant = [ "?How do you know you can't", + "Have you tried?", + "?Perhaps you can now" ] +iAm = [ "?Did you come to me because you are", + "?How long have you been", + "?Do you believe it is normal to be", + "?Do you enjoy being" ] +you = [ "We were discussing you --not me.", + "?Oh,", + "You're not really talking about me, are you?" ] +yes = [ "You seem quite positive.", + "Are you Sure?", + "I see.", + "I understand." ] +no = [ "Are you saying no just to be negative?", + "You are being a bit negative.", + "Why not?", + "Are you sure?", + "Why no?" ] +computer = [ "Do computers worry you?", + "Are you talking about me in particular?", + "Are you frightened by machines?", + "Why do you mention computers?", + "What do you think machines have to do with your problems?", + "Don't you think computers can help people?", + "What is it about machines that worries you?" ] +iWant = [ "?Why do you want", + "?What would it mean to you if you got", + "?Suppose you got", + "?What if you never got", + ".I sometimes also want" ] +question = [ "Why do you ask?", + "Does that question interest you?", + "What answer would please you the most?", + "What do you think?", + "Are such questions on your mind often?", + "What is it that you really want to know?", + "Have you asked anyone else?", + "Have you asked such questions before?", + "What else comes to mind when you ask that?" ] +name = [ "Names don't interest me.", + "I don't care about names --please go on." ] +because = [ "Is that the real reason?", + "Don't any other reasons come to mind?", + "Does that reason explain anything else?", + "What other reasons might there be?" ] +sorry = [ "Please don't apologise!", + "Apologies are not necessary.", + "What feelings do you have when you apologise?", + "Don't be so defensive!" ] +dream = [ "What does that dream suggest to you?", + "Do you dream often?", + "What persons appear in your dreams?", + "Are you disturbed by your dreams?" ] +hello = [ "How do you...please state your problem." ] +maybe = [ "You don't seem quite certain.", + "Why the uncertain tone?", + "Can't you be more positive?", + "You aren't sure?", + "Don't you know?" ] +your = [ "?Why are you concerned about my", + "?What about your own" ] +always = [ "Can you think of a specific example?", + "When?", + "What are you thinking of?", + "Really, always?" ] +think = [ "Do you really think so?", + "?But you are not sure you", + "?Do you doubt you" ] +alike = [ "In what way?", + "What resemblence do you see?", + "What does the similarity suggest to you?", + "What other connections do you see?", + "Cound there really be some connection?", + "How?" ] +friend = [ "Why do you bring up the topic of friends?", + "Do your friends worry you?", + "Do your friends pick on you?", + "Are you sure you have any friends?", + "Do you impose on your friends?", + "Perhaps your love for friends worries you." ] + +repeatMsgs = [ "Why did you repeat yourself?", + "Do you expect a different answer by repeating yourself?", + "Come, come, elucidate your thoughts.", + "Please don't repeat yourself!" ] + +nokeyMsgs = [ "I'm not sure I understand you fully.", + "What does that suggest to you?", + "I see.", + "Can you elaborate on that?", + "Say, do you have any psychological problems?" ] + +------------------------------------------------------------------------------- diff --git a/progs/demo/fact.hs b/progs/demo/fact.hs new file mode 100755 index 0000000..054183e --- /dev/null +++ b/progs/demo/fact.hs @@ -0,0 +1,14 @@ +{- This is a simple factorial program which uses the I/O system + to read the input and print the result -} + +module Main where + +fact :: Integer -> Integer +fact 0 = 1 +fact (n+1) = (n+1)*fact n +fact _ = error "Negative argument to factorial" + +main = appendChan stdout "Type in N: " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (fact (read (head (lines input))))) abort done + diff --git a/progs/demo/improved-add.hs b/progs/demo/improved-add.hs new file mode 100644 index 0000000..bdfcc2f --- /dev/null +++ b/progs/demo/improved-add.hs @@ -0,0 +1,21 @@ +-- this is an interactive program to read in two numbers and print their sum. + +module Main where + +main = readChan stdin abort $ \userInput -> + let inputLines = lines userInput in + readInt "Enter first number: " inputLines $ \num1 inputLines1 -> + readInt "Enter second number: " inputLines1 $ \ num2 _ -> + appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done + +readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue + +readInt prompt inputLines succ = + appendChan stdout prompt abort $ + case inputLines of + (l1 : rest) -> case (reads l1) of + [(x,"")] -> succ x rest + _ -> appendChan stdout + "Error - retype the number\n" abort $ + readInt prompt rest succ + _ -> appendChan stdout "Early EOF" abort done diff --git a/progs/demo/merge.hs b/progs/demo/merge.hs new file mode 100755 index 0000000..cf61f8f --- /dev/null +++ b/progs/demo/merge.hs @@ -0,0 +1,26 @@ +{- This is a simple merge sort -} + +module Merge where + +merge :: [Int] -> [Int] -> [Int] +merge [] x = x +merge x [] = x +merge l1@(a:b) l2@(c:d) | a < c = a:(merge b l2) + | otherwise = c:(merge l1 d) + +half [] = [] +half [x] = [x] +half (x:y:z) = x:r where r = half z + +sort [] = [] +sort [x] = [x] +sort l = merge (sort odds) (sort evens) where + odds = half l + evens = half (tail l) + +main = + appendChan stdout "Enter a list of integers separated by \",\"\n" abort $ + readChan stdin abort $ \ input -> + appendChan stdout + (show (sort (read ("[" ++ (head (lines input)) ++ "]")))) + abort done diff --git a/progs/demo/pascal.hs b/progs/demo/pascal.hs new file mode 100644 index 0000000..a26e9c9 --- /dev/null +++ b/progs/demo/pascal.hs @@ -0,0 +1,24 @@ +{- This uses lazy evaluation to define Pascals triangle -} + +module Main where + +pascal :: [[Int]] +pascal = [1] : [[x+y | (x,y) <- zip ([0]++r) (r++[0])] | r <- pascal] + +tab :: Int -> ShowS +tab 0 = id +tab (n+1) = showChar ' ' . tab n + +showRow :: [Int] -> ShowS +showRow [] = showChar '\n' +showRow (n:ns) = shows n . showChar ' ' . showRow ns + +showTriangle 1 (t:_) = showRow t +showTriangle (n+1) (t:ts) = tab n . showRow t . showTriangle n ts + +main = appendChan stdout "Number of rows: " abort $ + readChan stdin abort $ \input -> + appendChan stdout + (showTriangle (read (head (lines input))) pascal "") + abort done + diff --git a/progs/demo/pfac.hs b/progs/demo/pfac.hs new file mode 100644 index 0000000..516fc85 --- /dev/null +++ b/progs/demo/pfac.hs @@ -0,0 +1,21 @@ + +-- This is a parallel varient of factorial + +module Main where + +fac :: Int -> Int +fac 0 = 1 +fac n = pfac 1 n + +pfac :: Int -> Int -> Int +pfac low high | low == high = low + | low + 1 == high = (low * high) + | otherwise = pfac low mid * pfac (mid + 1) high + where + mid = (high + low) `div` 2 + +main = appendChan stdout "Type in N: " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (fac (read (head (lines input))))) abort done + + diff --git a/progs/demo/primes.hs b/progs/demo/primes.hs new file mode 100755 index 0000000..6c8fe79 --- /dev/null +++ b/progs/demo/primes.hs @@ -0,0 +1,16 @@ +-- This program implements Eratosthenes Sieve +-- to generate prime numbers. + +module Main where + +primes :: [Int] +primes = map head (iterate sieve [2 ..]) + +sieve :: [Int] -> [Int] +sieve (p:ps) = [x | x <- ps, (x `mod` p) /= 0] + +main = appendChan stdout "How many primes? " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (take (read (head (lines input))) primes)) + abort done + diff --git a/progs/demo/prolog/Engine.hs b/progs/demo/prolog/Engine.hs new file mode 100644 index 0000000..a269503 --- /dev/null +++ b/progs/demo/prolog/Engine.hs @@ -0,0 +1,61 @@ +-- +-- Stack based Prolog inference engine +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Engine(prove) where + +import PrologData +import Subst + +--- Calculation of solutions: + +-- the stack based engine maintains a stack of triples (s,goal,alts) +-- corresponding to backtrack points, where s is the substitution at that +-- point, goal is the outstanding goal and alts is a list of possible ways +-- of extending the current proof to find a solution. Each member of alts +-- is a pair (tp,u) where tp is a new subgoal that must be proved and u is +-- a unifying substitution that must be combined with the substitution s. +-- +-- the list of relevant clauses at each step in the execution is produced +-- by attempting to unify the head of the current goal with a suitably +-- renamed clause from the database. + +type Stack = [ (Subst, [Term], [Alt]) ] +type Alt = ([Term], Subst) + +alts :: Database -> Int -> Term -> [Alt] +alts db n g = [ (tp,u) | (tm:*tp) <- renClauses db n g, u <- unify g tm ] + +-- The use of a stack enables backtracking to be described explicitly, +-- in the following `state-based' definition of prove: + +prove :: Database -> [Term] -> [Subst] +prove db gl = solve 1 nullSubst gl [] + where + solve :: Int -> Subst -> [Term] -> Stack -> [Subst] + solve n s [] ow = s : backtrack n ow + solve n s (g:gs) ow + | g==theCut = solve n s gs (cut ow) + | otherwise = choose n s gs (alts db n (apply s g)) ow + + choose :: Int -> Subst -> [Term] -> [Alt] -> Stack -> [Subst] + choose n s gs [] ow = backtrack n ow + choose n s gs ((tp,u):rs) ow = solve (n+1) (u@@s) (tp++gs) ((s,gs,rs):ow) + + backtrack :: Int -> Stack -> [Subst] + backtrack n [] = [] + backtrack n ((s,gs,rs):ow) = choose (n-1) s gs rs ow + + +--- Special definitions for the cut predicate: + +theCut :: Term +theCut = Struct "!" [] + +cut :: Stack -> Stack +cut (top:(s,gl,_):ss) = top:(s,gl,[]):ss +cut ss = ss + +--- End of Engine.hs diff --git a/progs/demo/prolog/Engine.hu b/progs/demo/prolog/Engine.hu new file mode 100644 index 0000000..5a64277 --- /dev/null +++ b/progs/demo/prolog/Engine.hu @@ -0,0 +1,3 @@ +Engine.hs +PrologData.hu +Subst.hu diff --git a/progs/demo/prolog/Interact.hs b/progs/demo/prolog/Interact.hs new file mode 100644 index 0000000..c8bf516 --- /dev/null +++ b/progs/demo/prolog/Interact.hs @@ -0,0 +1,76 @@ +-- +-- Interactive utility functions +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Interact(Interactive(..), skip, end, readln, writeln, readch) where + +-- The functions defined in this module provide basic facilities for +-- writing line-oriented interactive programs (i.e. a function mapping +-- an input string to an appropriate output string). These definitions +-- are an enhancement of thos in B+W 7.8 +-- +-- skip p is an interactive program which consumes no input, produces +-- no output and then behaves like the interactive program p. +-- end is an interactive program which ignores the input and +-- produces no output. +-- writeln txt p is an interactive program which outputs the message txt +-- and then behaves like the interactive program p +-- readch act def is an interactive program which reads the first character c +-- from the input stream and behaves like the interactive +-- program act c. If the input character stream is empty, +-- readch act def prints the default string def and terminates. +-- +-- readln p g is an interactive program which prints the prompt p and +-- reads a line (upto the first carriage return, or end of +-- input) from the input stream. It then behaves like g line. +-- Backspace characters included in the input stream are +-- interpretted in the usual way. + +type Interactive = String -> String + +--- Interactive program combining forms: + +skip :: Interactive -> Interactive +skip p inn = p inn -- a dressed up identity function + +end :: Interactive +end inn = "" + +writeln :: String -> Interactive -> Interactive +writeln txt p inn = txt ++ p inn + +readch :: (Char -> Interactive) -> String -> Interactive +readch act def "" = def +readch act def (c:cs) = act c cs + +readln :: String -> (String -> Interactive) -> Interactive +readln prompt g inn = prompt ++ lineOut 0 line ++ "\n" + ++ g (noBackSpaces line) input' + where line = before '\n' inn + input' = after '\n' inn + after x = tail . dropWhile (x/=) + before x = takeWhile (x/=) + +--- Filter out backspaces etc: + +rubout :: Char -> Bool +rubout c = (c=='\DEL' || c=='\BS') + +lineOut :: Int -> String -> String +lineOut n "" = "" +lineOut n (c:cs) + | n>0 && rubout c = "\BS \BS" ++ lineOut (n-1) cs + | n==0 && rubout c = lineOut 0 cs + | otherwise = c:lineOut (n+1) cs + +noBackSpaces :: String -> String +noBackSpaces = reverse . delete 0 . reverse + where delete n "" = "" + delete n (c:cs) + | rubout c = delete (n+1) cs + | n>0 = delete (n-1) cs + | otherwise = c:delete 0 cs + +--- End of Interact.hs diff --git a/progs/demo/prolog/Interact.hu b/progs/demo/prolog/Interact.hu new file mode 100644 index 0000000..41ebb9d --- /dev/null +++ b/progs/demo/prolog/Interact.hu @@ -0,0 +1,2 @@ +Interact.hs + diff --git a/progs/demo/prolog/Main.hs b/progs/demo/prolog/Main.hs new file mode 100644 index 0000000..56d83a8 --- /dev/null +++ b/progs/demo/prolog/Main.hs @@ -0,0 +1,87 @@ +-- +-- Prolog interpreter top level module +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Main(main) where + +import PrologData +import Parse +import Interact +import Subst +import Engine +import Version + +--- Command structure and parsing: + +data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange + +command :: Parser Command +command = just (sptok "bye" `orelse` sptok "quit") `do` (\quit->Quit) + `orelse` + just (okay NoChange) + `orelse` + just (sptok "??") `do` (\show->Show) + `orelse` + just clause `do` Fact + `orelse` + just (sptok "?-" `seq` termlist) `do` (\(q,ts)->Query ts) + `orelse` + okay Error + +--- Main program read-solve-print loop: + +signOn :: String +signOn = "Mini Prolog Version 1.5 (" ++ version ++ ")\n\n" + +main :: Dialogue +main = --echo False abort + (appendChan stdout signOn abort + (appendChan stdout ("Reading " ++ stdlib ++ "...") abort + (readFile stdlib + (\fail -> appendChan stdout "not found\n" abort + (interpreter "")) + (\lib -> appendChan stdout "done\n" abort + (interpreter lib)) + ))) + +stdlib :: String +stdlib = "$HASKELL/progs/demo/prolog/stdlib" + +interpreter :: String -> Dialogue +interpreter lib = readChan stdin abort + (\inn -> appendChan stdout (loop startDb inn) abort done) + where startDb = foldl addClause emptyDb clauses + clauses = [r | ((r,""):_)<-map clause (lines lib)] + +loop :: Database -> String -> String +loop db = readln "> " (exec db . fst . head . command) + +exec :: Database -> Command -> String -> String +exec db (Fact r) = skip (loop (addClause db r)) +exec db (Query q) = demonstrate db q +exec db Show = writeln (show db) (loop db) +exec db Error = writeln "I don't understand\n" (loop db) +exec db Quit = writeln "Thank you and goodbye\n" end +exec db NoChange = skip (loop db) + +--- Handle printing of solutions etc... + +solution :: [Id] -> Subst -> [String] +solution vs s = [ show (Var i) ++ " = " ++ show v + | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ] + +demonstrate :: Database -> [Term] -> Interactive +demonstrate db q = printOut (map (solution vs) (prove db q)) + where vs = (nub . concat . map varsIn) q + printOut [] = writeln "no.\n" (loop db) + printOut ([]:bs) = writeln "yes.\n" (loop db) + printOut (b:bs) = writeln (doLines b) (nextReqd bs) + doLines = foldr1 (\xs ys -> xs ++ "\n" ++ ys) + nextReqd bs = writeln " " + (readch (\c->if c==';' + then writeln ";\n" (printOut bs) + else writeln "\n" (loop db)) "") + +--- End of Main.hs diff --git a/progs/demo/prolog/Main.hu b/progs/demo/prolog/Main.hu new file mode 100644 index 0000000..a936ca6 --- /dev/null +++ b/progs/demo/prolog/Main.hu @@ -0,0 +1,6 @@ +Main.hs +Parse.hu +PrologData.hu +Interact.hu +Engine.hu +Version.hu diff --git a/progs/demo/prolog/Parse.hs b/progs/demo/prolog/Parse.hs new file mode 100644 index 0000000..0487432 --- /dev/null +++ b/progs/demo/prolog/Parse.hs @@ -0,0 +1,116 @@ +-- +-- General parsing library, based on Richard Bird's parselib.orw for Orwell +-- (with a number of extensions) +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Parse(Parser(..), fail, okay, tok, sat, orelse, seq, do, + sptok, just, listOf, many, sp, many1) where + +infixr 6 `seq` +infixl 5 `do` +infixr 4 `orelse` + +--- Type definition: + +type Parser a = [Char] -> [(a,[Char])] + +-- A parser is a function which maps an input stream of characters into +-- a list of pairs each containing a parsed value and the remainder of the +-- unused input stream. This approach allows us to use the list of +-- successes technique to detect errors (i.e. empty list ==> syntax error). +-- it also permits the use of ambiguous grammars in which there may be more +-- than one valid parse of an input string. + +--- Primitive parsers: + +-- fail is a parser which always fails. +-- okay v is a parser which always succeeds without consuming any characters +-- from the input string, with parsed value v. +-- tok w is a parser which succeeds if the input stream begins with the +-- string (token) w, returning the matching string and the following +-- input. If the input does not begin with w then the parser fails. +-- sat p is a parser which succeeds with value c if c is the first input +-- character and c satisfies the predicate p. + +fail :: Parser a +fail inn = [] + +okay :: a -> Parser a +okay v inn = [(v,inn)] + +tok :: [Char] -> Parser [Char] +tok w inn = [(w, drop n inn) | w == take n inn] + where n = length w + +sat :: (Char -> Bool) -> Parser Char +sat p [] = [] +sat p (c:inn) = [ (c,inn) | p c ] + +--- Parser combinators: + +-- p1 `orelse` p2 is a parser which returns all possible parses of the input +-- string, first using the parser p1, then using parser p2. +-- p1 `seq` p2 is a parser which returns pairs of values (v1,v2) where +-- v1 is the result of parsing the input string using p1 and +-- v2 is the result of parsing the remaining input using p2. +-- p `do` f is a parser which behaves like the parser p, but returns +-- the value f v wherever p would have returned the value v. +-- +-- just p is a parser which behaves like the parser p, but rejects any +-- parses in which the remaining input string is not blank. +-- sp p behaves like the parser p, but ignores leading spaces. +-- sptok w behaves like the parser tok w, but ignores leading spaces. +-- +-- many p returns a list of values, each parsed using the parser p. +-- many1 p parses a non-empty list of values, each parsed using p. +-- listOf p s parses a list of input values using the parser p, with +-- separators parsed using the parser s. + +orelse :: Parser a -> Parser a -> Parser a +p1 `orelse` p2 = \inn->p1 inn ++ p2 inn + +seq :: Parser a -> Parser b -> Parser (a,b) +p1 `seq` p2 = \inn->[((v1,v2),inn2) | (v1,inn1) <- p1 inn, (v2,inn2) <- p2 inn1] + +do :: Parser a -> (a -> b) -> Parser b +p `do` f = \inn->[(f v, inn1) | (v,inn1) <- p inn] + +just :: Parser a -> Parser a +just p inn = [ (v,"") | (v,inn')<- p inn, dropWhile (' '==) inn' == "" ] + +sp :: Parser a -> Parser a +sp p = p . dropWhile (' '==) + +sptok :: [Char] -> Parser [Char] +sptok = sp . tok + +many :: Parser a -> Parser [a] +many p = q + where q = ((p `seq` q) `do` makeList) `orelse` (okay []) + +many1 :: Parser a -> Parser [a] +many1 p = p `seq` many p `do` makeList + +listOf :: Parser a -> Parser b -> Parser [a] +listOf p s = p `seq` many (s `seq` p) `do` nonempty + `orelse` okay [] + where nonempty (x,xs) = x:(map snd xs) + +--- Internals: + +makeList :: (a,[a]) -> [a] +makeList (x,xs) = x:xs + +{- +-- an attempt to optimise the performance of the standard prelude function +-- `take' in Haskell B 0.99.3 gives the wrong semantics. The original +-- definition, given below works correctly and is used in the above. + +safetake :: (Integral a) => a -> [b] -> [b] +safetake _ [] = [] +safetake 0 _ = [] +safetake (n+1) (x:xs) = x : safetake n xs +-} +--- End of Parse.hs diff --git a/progs/demo/prolog/Parse.hu b/progs/demo/prolog/Parse.hu new file mode 100644 index 0000000..44cc302 --- /dev/null +++ b/progs/demo/prolog/Parse.hu @@ -0,0 +1 @@ +Parse.hs diff --git a/progs/demo/prolog/PrologData.hs b/progs/demo/prolog/PrologData.hs new file mode 100644 index 0000000..4ff3173 --- /dev/null +++ b/progs/demo/prolog/PrologData.hs @@ -0,0 +1,121 @@ +-- +-- Representation of Prolog Terms, Clauses and Databases +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module PrologData(Id(..), Atom(..), Term(..), term, termlist, varsIn, + Clause((:*)), clause, + Database, emptyDb, renClauses, addClause) where + +import Parse + +infix 6 :* + +--- Prolog Terms: + +type Id = (Int,String) +type Atom = String +data Term = Var Id | Struct Atom [Term] + deriving Eq +data Clause = Term :* [Term] +data Database = Db [(Atom,[Clause])] + +--- Determine the list of variables in a term: + +varsIn :: Term -> [Id] +varsIn (Var i) = [i] +varsIn (Struct i ts) = (nub . concat . map varsIn) ts + +renameVars :: Int -> Term -> Term +renameVars lev (Var (n,s)) = Var (lev,s) +renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts) + +--- Functions for manipulating databases (as an abstract datatype) + +emptyDb :: Database +emptyDb = Db [] + +renClauses :: Database -> Int -> Term -> [Clause] +renClauses db n (Var _) = [] +renClauses db n (Struct a _) = [ r tm:*map r tp | (tm:*tp)<-clausesFor a db ] + where r = renameVars n + +clausesFor :: Atom -> Database -> [Clause] +clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of + [] -> [] + ((n,rs):_) -> if a==n then rs else [] + +addClause :: Database -> Clause -> Database +addClause (Db rss) r@(Struct a _ :* _) + = Db (initialPart ++ + case lastPart of + [] -> [(a,[r])] + ((n,rs):rss') -> if a==n then (n,rs++[r]):rss' + else (a,[r]):lastPart) + where (initialPart,lastPart) = span (\(n,rs) -> n<a) rss + +--- Output functions (defined as instances of Text): + +instance Text Term where + showsPrec p (Var (n,s)) + | n==0 = showString s + | otherwise = showString s . showChar '_' . shows n + showsPrec p (Struct a []) = showString a + showsPrec p (Struct a ts) = showString a . showChar '(' + . showWithSep "," ts + . showChar ')' + +instance Text Clause where + showsPrec p (t:*[]) = shows t . showChar '.' + showsPrec p (t:*gs) = shows t . showString ":-" + . showWithSep "," gs + . showChar '.' + +instance Text Database where + showsPrec p (Db []) = showString "-- Empty Database --\n" + showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v) + [ showWithTerm "\n" rs | (i,rs)<-rss ] + +--- Local functions for use in defining instances of Text: + +showWithSep :: Text a => String -> [a] -> ShowS +showWithSep s [x] = shows x +showWithSep s (x:xs) = shows x . showString s . showWithSep s xs + +showWithTerm :: Text a => String -> [a] -> ShowS +showWithTerm s xs = foldr1 (.) [shows x . showString s | x<-xs] + +--- String parsing functions for Terms and Clauses: +--- Local definitions: + +letter :: Parser Char +letter = sat (\c -> isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!") + +variable :: Parser Term +variable = sat isUpper `seq` many letter `do` makeVar + where makeVar (initial,rest) = Var (0,(initial:rest)) + +struct :: Parser Term +struct = many letter `seq` (sptok "(" `seq` termlist `seq` sptok ")" + `do` (\(o,(ts,c))->ts) + `orelse` + okay []) + `do` (\(name,terms)->Struct name terms) + +--- Exports: + +term :: Parser Term +term = sp (variable `orelse` struct) + +termlist :: Parser [Term] +termlist = listOf term (sptok ",") + +clause :: Parser Clause +clause = sp struct `seq` (sptok ":-" `seq` listOf term (sptok ",") + `do` (\(from,body)->body) + `orelse` okay []) + `seq` sptok "." + `do` (\(head,(goals,dot))->head:*goals) + +--- End of PrologData.hs diff --git a/progs/demo/prolog/PrologData.hu b/progs/demo/prolog/PrologData.hu new file mode 100644 index 0000000..362d35f --- /dev/null +++ b/progs/demo/prolog/PrologData.hu @@ -0,0 +1,2 @@ +PrologData.hs +Parse.hu diff --git a/progs/demo/prolog/README b/progs/demo/prolog/README new file mode 100644 index 0000000..73dbc1b --- /dev/null +++ b/progs/demo/prolog/README @@ -0,0 +1,3 @@ +This is a mini prolog interpreter written my Mark Jones. It +was slightly adapted from version in the hbc release. + diff --git a/progs/demo/prolog/Subst.hs b/progs/demo/prolog/Subst.hs new file mode 100644 index 0000000..f96e462 --- /dev/null +++ b/progs/demo/prolog/Subst.hs @@ -0,0 +1,65 @@ +-- +-- Substitutions and Unification of Prolog Terms +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Subst(Subst(..), nullSubst, (>!), (@@), apply, unify) where + +import PrologData + +infixr 3 @@ +infix 4 >! + +--- Substitutions: + +type Subst = Id -> Term + +-- substitutions are represented by functions mapping identifiers to terms. +-- +-- apply s extends the substitution s to a function mapping terms to terms +-- nullSubst is the empty substitution which maps every identifier to the +-- same identifier (as a term). +-- i >! t is the substitution which maps the identifier i to the term t, +-- but otherwise behaves like nullSubst. +-- s1 @@ s2 is the composition of substitutions s1 and s2 +-- N.B. apply is a monoid homomorphism from (Subst,nullSubst,(@@)) +-- to (Term -> Term, id, (.)) in the sense that: +-- apply (s1 @@ s2) = apply s1 . apply s2 +-- s @@ nullSubst = s = nullSubst @@ s + +apply :: Subst -> Term -> Term +apply s (Var i) = s i +apply s (Struct a ts) = Struct a (map (apply s) ts) + +nullSubst :: Subst +nullSubst i = Var i + +(>!) :: Id -> Term -> Subst +(>!) i t j | j==i = t + | otherwise = Var j + +(@@) :: Subst -> Subst -> Subst +s1 @@ s2 = apply s1 . s2 + +--- Unification: + +-- unify t1 t2 returns a list containing a single substitution s which is +-- the most general unifier of terms t1 t2. If no unifier +-- exists, the list returned is empty. + +unify :: Term -> Term -> [Subst] +unify (Var x) (Var y) = if x==y then [nullSubst] else [x>!Var y] +unify (Var x) t2 = [ x >! t2 | not (x `elem` varsIn t2) ] +unify t1 (Var y) = [ y >! t1 | not (y `elem` varsIn t1) ] +unify (Struct a ts) (Struct b ss) = [ u | a==b, u<-listUnify ts ss ] + +listUnify :: [Term] -> [Term] -> [Subst] +listUnify [] [] = [nullSubst] +listUnify [] (r:rs) = [] +listUnify (t:ts) [] = [] +listUnify (t:ts) (r:rs) = [ u2 @@ u1 | u1<-unify t r, + u2<-listUnify (map (apply u1) ts) + (map (apply u1) rs) ] + +--- End of Subst.hs diff --git a/progs/demo/prolog/Subst.hu b/progs/demo/prolog/Subst.hu new file mode 100644 index 0000000..1bb92fb --- /dev/null +++ b/progs/demo/prolog/Subst.hu @@ -0,0 +1,2 @@ +Subst.hs +PrologData.hu diff --git a/progs/demo/prolog/Version.hs b/progs/demo/prolog/Version.hs new file mode 100644 index 0000000..c580f4b --- /dev/null +++ b/progs/demo/prolog/Version.hs @@ -0,0 +1 @@ +module Version where version="tree based" diff --git a/progs/demo/prolog/Version.hu b/progs/demo/prolog/Version.hu new file mode 100644 index 0000000..244a511 --- /dev/null +++ b/progs/demo/prolog/Version.hu @@ -0,0 +1 @@ +Version.hs diff --git a/progs/demo/prolog/stdlib b/progs/demo/prolog/stdlib new file mode 100644 index 0000000..76d2b8c --- /dev/null +++ b/progs/demo/prolog/stdlib @@ -0,0 +1,38 @@ +This file contains a list of predicate definitions that will automatically +be read into Mini Prolog at the beginning of a session. Each clause in this +file must be entered on a single line and lines containing syntax errors are +always ignored. This includes the first few lines of this file and provides +a simple way to include comments. + +append(nil,X,X). +append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W). + +equals(X,X). + +not(X):-X,!,false. +not(X). + +or(X,Y):-X. +or(X,Y):-Y. + +and(X,Y):-X,Y. + +reverse(nil,nil). +reverse(cons(A,X),Y):-and(reverse(X,Z),append(Z,cons(A,nil),Y)). + +palindromes(X):-and(reverse(X,Y),equals(X,Y)). + +mul2(A,B):-append(A,A,B). +mul4(A,B):-and(mul2(A,C),mul2(C,B)). +mul8(A,B):-and(mul4(A,C),mul2(C,B)). +mul16(A,B):-and(mul8(A,C),mul2(C,B)). +mul32(A,B):-and(mul16(A,C),mul2(C,B)). +mul64(A,B):-and(mul32(A,C),mul2(C,B)). +mul128(A,B):-and(mul64(A,C),mul2(C,B)). +mul256(A,B):-and(mul128(A,C),mul2(C,B)). +mul512(A,B):-and(mul256(A,C),mul2(C,B)). +mul1024(A,B):-and(mul512(A,C),mul2(C,B)). + +true. + +End of stdlib diff --git a/progs/demo/queens.hs b/progs/demo/queens.hs new file mode 100755 index 0000000..0f8de59 --- /dev/null +++ b/progs/demo/queens.hs @@ -0,0 +1,40 @@ +{- This is the n Queens problem. -} + +module Main where + +queens :: Int -> [[Int]] +queens size = queens' size size + +queens' :: Int -> Int -> [[Int]] +queens' 0 _ = [[]] +queens' (n+1) size = [q:qs | qs <- queens' n size, q <- [1..size], + not (threatens q qs)] + +threatens :: Int -> [Int] -> Bool +threatens q qs = q `elem` qs || q `elem` (diagonals 1 qs) + +diagonals :: Int -> [Int] -> [Int] +diagonals _ [] = [] +diagonals n (q:qs) = (q+n) : (q-n) : diagonals (n+1) qs + +main = appendChan stdout "Enter board size: " abort $ + readChan stdin abort $ \input -> + let line1 : ~(line2 : _) = lines input + size = read line1 + solns = read line2 + in if size == 0 then done else -- This causes the size to actually read + appendChan stdout "Number of solutions: " abort $ + appendChan stdout (concat (map (\x -> showBoard size x) + (take solns (queens size)))) + abort done + +showBoard :: Int -> [Int] -> String + +showBoard size pos = + concat (map showRow pos) ++ "\n" + where + showRow n = concat [if i == n then "Q " else ". " | i <- [1..size]] + ++ "\n" + + + diff --git a/progs/demo/quicksort.hs b/progs/demo/quicksort.hs new file mode 100644 index 0000000..30b4ab4 --- /dev/null +++ b/progs/demo/quicksort.hs @@ -0,0 +1,13 @@ +-- Quick sort for Haskell. + +module Main where + +qs :: [Int] -> [Int] +qs [] = [] +qs (a:as) = qs [x | x <- as, x <= a] ++ [a] ++ qs [x | x <- as, x > a] + +main = + appendChan stdout "Enter a list of integers separated by \",\"\n" abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (qs (read ("[" ++ (head (lines input)) ++ "]")))) + abort done diff --git a/progs/lib/README b/progs/lib/README new file mode 100644 index 0000000..910be2d --- /dev/null +++ b/progs/lib/README @@ -0,0 +1 @@ +This directory contains supported libraries for Yale Haskell. diff --git a/progs/lib/X11/README b/progs/lib/X11/README new file mode 100644 index 0000000..db748e4 --- /dev/null +++ b/progs/lib/X11/README @@ -0,0 +1,11 @@ +This directory contains the Haskell->CLX support code. + +If you see errors like "ID 42 is a :WM_RESIZE_HINTS, not a window", +you can get rid of them by loading clx-patch.lisp. This seems to be a +bug where CLX is not consistent with the protocol in some way; we've +seen it on some machines and not others. The line + +(load "$HASKELL/progs/lib/X11/clx-patch.lisp") + +can be placed in your .yhaskell file to load the patch on startup. + diff --git a/progs/lib/X11/clx-patch.lisp b/progs/lib/X11/clx-patch.lisp new file mode 100644 index 0000000..fe2a5e3 --- /dev/null +++ b/progs/lib/X11/clx-patch.lisp @@ -0,0 +1,39 @@ +(lisp:in-package 'xlib) +(defmacro generate-lookup-functions (useless-name &body types) + `(within-definition (,useless-name generate-lookup-functions) + ,@(mapcar + #'(lambda (type) + `(defun ,(xintern 'lookup- type) + (display id) + (declare (type display display) + (type resource-id id)) + (declare (values ,type)) + ,(if (member type *clx-cached-types*) + `(let ((,type (lookup-resource-id display id))) + (cond ((null ,type) ;; Not found, create and s +ave it. + (setq ,type (,(xintern 'make- type) + :display display :id id)) + (save-id display id ,type)) + ;; Found. Check the type + ,(cond ((null '()) ;*type-check?*) + `(t ,type)) + ((member type '(window pixmap)) + `((type? ,type 'drawable) ,type) +) + (t `((type? ,type ',type) ,type)) +) + ,@(when '() ;*type-check?* + `((t (x-error 'lookup-error + :id id + :display display + :type ',type + :object ,type)))))) + ;; Not being cached. Create a new one each time. + `(,(xintern 'make- type) + :display display :id id)))) + types))) +(macroexpand + (generate-lookup-functions ignore + window)) + diff --git a/progs/lib/X11/xlib.hs b/progs/lib/X11/xlib.hs new file mode 100644 index 0000000..716cc8c --- /dev/null +++ b/progs/lib/X11/xlib.hs @@ -0,0 +1,877 @@ +module Xlib(XLibTypes..,XLibPrims..) where +import XLibTypes +import XLibPrims + +module XLibTypes(XDisplay, XScreen, XWindow, XGcontext, XPixmap, + XColormap, XCursor, XFont, XImage, XMaybe(..), XError(..), + XBitmap(..), XKeysymTable(..), XBitVec(..), + XPixarray(..), XByteVec(..), XAtom(..), XProperty(..), + XPixel(..), XDrawable(..), XTime(..), XSwitch(..), + XWindowPlace(..), XEventMode(..), XEventKind(..), + XWindowVisibility(..), XWindowStackMode(..), + XPropertyState(..), XMapReqType(..), XGraphFun(..), + XEvent(..), XEventType(..), XEventSlot(..), XEventMask(..), + XEventMaskKey(..), XStateMask(..), XStateMaskKey(..), + XWinAttribute(..),XGCAttribute(..), XImAttribute(..), + XGrabAttribute(..), XArcMode(..), XCapStyle(..), + XClipMask(..), XFillRule(..), XFillStyle(..), + XFunction(..), XJoinStyle(..), XLineStyle(..), + XSubwindowMode(..), XPoint(..), XSize(..), XRect(..), + XArc(..), XBitmapFormat(..), XByteOrder(..), + XPixmapFormat(..), XVisualInfo(..), XVisualClass(..), + XFillContent(..), XBackingStore(..), XGravity(..), + XWindowClass(..), XMapState(..), XImageData(..), + XImageFormat(..), XImageType(..), XDrawDirection(..), + XColor(..), XInputFocus(..), XGrabStatus(..), + XKeysym(..), XCloseDownMode(..), XScreenSaver(..)) + where + +data XMaybe a {-# STRICT #-} = XSome a + | XNull + --deriving (Printers) + +data XDisplay = XDisplay --deriving (Printers) +data XScreen = XScreen --deriving (Printers) +data XWindow = XWindow --deriving (Printers) +data XGcontext = XGcontext --deriving (Printers) +data XPixmap = XPixmap --deriving (Printers) +data XColormap = XColormap --deriving (Printers) +data XCursor = XCursor --deriving (Printers) +data XFont = XFont --deriving (Printers) +data XImage = XImage --deriving (Printers) + +data XError {-# STRICT #-} + = XError String + --deriving Printers +data XBitmap {-# STRICT #-} + = XBitmap [[Int]] +instance Text(XBitmap) where + showsPrec p x = showString "<<XBitMap>>" + +data XKeysymTable {-# STRICT #-} + = XKeysymTable [[Integer]] +instance Text(XKeysymTable) where + showsPrec p x = showString "<<XKeysymTable>>" + +data XBitVec {-# STRICT #-} + = XBitVec [Int] +instance Text(XBitVec) where + showsPrec p x = showString "<<XBitVec>>" + +data XPixarray {-# STRICT #-} + = XPixarray [[Integer]] +instance Text(XPixarray) where + showsPrec p x = showString "<<XPixarray>>" + +data XByteVec {-# STRICT #-} + = XByteVec [Int] +instance Text(XByteVec) where + showsPrec p x = showString "<<XByteVec>>" + + +data XAtom {-# STRICT #-} + = XAtom String + --deriving (Printers) + +data XProperty {-#STRICT #-} + = XProperty [Integer] -- data + XAtom -- type + Int -- format + --deriving (Printers) + +data XPixel {-# STRICT #-} + = XPixel Integer + --deriving (Printers) + +data XDrawable {-# STRICT #-} + = XDrawWindow XWindow + | XDrawPixmap XPixmap + --deriving (Printers) + +data XTime {-# STRICT #-} + = XTime Integer + --deriving (Printers) + +data XSwitch = XOn + | XOff + --deriving (Printers) + +data XWindowPlace = XTopPlace + | XBottomPlace + --deriving (Printers) + +data XEventMode = XNormalMode + | XGrabMode + | XUngrabMode + | XWhileGrabbedMode + --deriving (Printers) + +data XEventKind = XAncestorKind + | XVirtualKind + | XInferiorKind + | XNonlinearKind + | XNonlinearVirtualKind + | XPointerKind + | XPointerRootKind + | XNoneKind + --deriving (Printers) + +data XWindowVisibility = XUnobscured + | XPartiallyObscured + | XFullyObscured + --deriving (Printers) + +data XWindowStackMode = XStackAbove + | XStackBelow + | XStackTopIf + | XStackBottomIf + | XStackOpposite + --deriving (Printers) + +data XPropertyState = XNewValueProperty + | XDeletedProperty + --deriving (Printers) + +data XMapReqType = XModifierMapping + | XKeyboardMapping + | XPointerMapping + --deriving (Printers) + +data XGraphFun {-# STRICT #-} + = XGraphFun Int -- major opcode + Int -- minor opcode + --deriving (Printers) + +data XEvent {-# STRICT #-} + = XEvent XEventType + [XEventSlot] + +data XEventType = XKeyPressEvent + | XKeyReleaseEvent + | XButtonPressEvent + | XButtonReleaseEvent + | XMotionNotifyEvent + | XEnterNotifyEvent + | XLeaveNotifyEvent + | XFocusInEvent + | XFocusOutEvent + | XKeymapNotifyEvent + | XMappingNotifyEvent + | XExposureEvent + | XGraphicsExposureEvent + | XNoExposureEvent + | XCirculateNotifyEvent + | XConfigureNotifyEvent + | XCreateNotifyEvent + | XDestroyNotifyEvent + | XGravityNotifyEvent + | XMapNotifyEvent + | XReparentNotifyEvent + | XUnmapNotifyEvent + | XVisibilityNotifyEvent + | XCirculateRequestEvent + | XColormapNotifyEvent + | XConfigureRequestEvent + | XMapRequestEvent + | XResizeRequestEvent + | XClientMessageEvent + | XPropertyNotifyEvent + | XSelectionClearEvent + | XSelectionNotifyEvent + | XSelectionRequestEvent + | XOtherEvents + --deriving Printers + +data XEventSlot {-# STRICT #-} + = XEventWindow XWindow + | XEventEventWindow XWindow + | XEventCode Int + | XEventPos XPoint + | XEventState XStateMask + | XEventTime XTime + | XEventRoot XWindow + | XEventRootPos XPoint + | XEventChild (XMaybe XWindow) + | XEventSameScreenP Bool + | XEventHintP Bool + | XEventMode XEventMode + | XEventKind XEventKind + | XEventFocusP Bool + | XEventKeymap XBitVec + | XEventRequest XMapReqType + | XEventStart Int + | XEventCount Int + | XEventRect XRect + | XEventDrawable XDrawable + | XEventXGraphFun XGraphFun + | XEventPlace XWindowPlace + | XEventBorderWidth Int + | XEventAboveSibling (XMaybe XWindow) + | XEventOverrideRedirectP Bool + | XEventParent XWindow + | XEventConfigureP Bool + | XEventVisibility XWindowVisibility + | XEventNewP Bool + | XEventInstalledP Bool + | XEventStackMode XWindowStackMode + | XEventValueMask Int + | XEventSize XSize + | XEventMessage XProperty + | XEventPropertyState XPropertyState + | XEventAtom XAtom + | XEventSelection XAtom + | XEventTarget XAtom + | XEventProperty (XMaybe XAtom) + | XEventRequestor XWindow + --deriving Printers + +data XEventMask {-# STRICT #-} + = XEventMask [XEventMaskKey] + --deriving (Printers) + +data XEventMaskKey + = XButton1Motion + | XButton2Motion + | XButton3Motion + | XButton4Motion + | XButton5Motion + | XButtonMotion + | XButtonPress + | XButtonRelease + | XColormapChange + | XEnterWindow + | XExposure + | XFocusChange + | XKeyPress + | XKeyRelease + | XKeymapState + | XLeaveWindow + | XOwnerGrabButton + | XPointerMotion + | XPointerMotionHint + | XPropertyChange + | XResizeRedirect + | XStructureNotify + | XSubstructureRedirect + | XVisibilityChange + --deriving (Printers) + +data XStateMask {-# STRICT #-} + = XStateMask [XStateMaskKey] + --deriving (Printers) + +data XStateMaskKey + = XShift + | XLock + | XControl + | XMod1 + | XMod2 + | XMod3 + | XMod4 + | XMod5 + | XButton1 + | XButton2 + | XButton3 + | XButton4 + | XButton5 + --deriving (Printers) + +data XWinAttribute {-# STRICT #-} + = XWinBackground XPixel + | XWinEventMask XEventMask + | XWinDepth Int + | XWinBorderWidth Int + | XWinClass XWindowClass + | XWinVisual Int + | XWinBorder XFillContent + | XWinBackingStore XBackingStore + | XWinBackingPlanes XPixel + | XWinBackingPixel XPixel + | XWinSaveUnder XSwitch + | XWinDoNotPropagateMask XEventMask + | XWinOverrideRedirect XSwitch + | XWinColormap XColormap + | XWinCursor XCursor + --deriving (Printers) + +data XGCAttribute {-# STRICT #-} + = XGCArcMode XArcMode + | XGCBackground XPixel + | XGCCapStyle XCapStyle + | XGCClipMask XClipMask + | XGCClipOrigin XPoint + | XGCDashOffset Int + | XGCDashes [Int] + | XGCExposures XSwitch + | XGCFillRule XFillRule + | XGCFillStyle XFillStyle + | XGCFont XFont + | XGCForeground XPixel + | XGCFunction XFunction + | XGCJoinStyle XJoinStyle + | XGCLineStyle XLineStyle + | XGCLineWidth Int + | XGCPlaneMask XPixel + | XGCStipple XPixmap + | XGCSubwindowMode XSubwindowMode + | XGCTile XPixmap + | XGCTileOrigin XPoint + --deriving (Printers) + +data XImAttribute {-# STRICT #-} + = XImBitLsbFirstP Bool + | XImBitsPerPixel Int + | XImBlueMask XPixel + | XImByteLsbFirstP Bool + | XImBytesPerLine Int + | XImData XImageData + | XImDepth Int + | XImFormat XImageFormat + | XImGreenMask XPixel + | XImSize XSize + | XImName String + | XImRedMask XPixel + | XImHotSpot XPoint + --deriving (Printers) + +data XGrabAttribute {-# STRICT #-} + = XGrabOwnerP Bool + | XGrabSyncPointerP Bool + | XGrabSyncKeyboardP Bool + | XGrabConfineTo XWindow + | XGrabCursor XCursor + --deriving (Printers) + +data XArcMode = XChord + | XPieSlice + --deriving (Printers) + +data XCapStyle = XButt + | XNotLast + | XProjecting + | XRound + --deriving (Printers) + +data XClipMask {-# STRICT #-} + = XClipMaskPixmap XPixmap + | XClipMaskRects [XRect] + | XClipMaskNone + --deriving (Printers) + +data XFillRule = XFillEvenOdd + | XFillWinding + --deriving (Printers) + +data XFillStyle = XFillOpaqueStippled + | XFillSolid + | XFillStippled + | XFillTiled + --deriving (Printers) + +data XFunction = XBoole1 + | XBoole2 + | XBooleAndC1 + | XBooleAndC2 + | XBooleAnd + | XBooleC1 + | XBooleC2 + | XBooleClr + | XBooleEqv + | XBooleIor + | XBooleNand + | XBooleNor + | XBooleOrc1 + | XBooleOrc2 + | XBooleSet + | XBooleXor + --deriving (Printers) + +data XJoinStyle = XJoinBevel + | XJoinMiter + | XJoinRound + --deriving (Printers) + +data XLineStyle = XLineSolid + | XLineDoubleDash + | XLineOnOffDash + --deriving (Printers) + +data XSubwindowMode = XClipByChildren + | XIncludeInferiors + --deriving (Printers) + +-- BASIC GEOMETRY + +data XPoint {-# STRICT #-} = XPoint Int Int -- x,y + --deriving (Printers) + +data XSize {-# STRICT #-} = XSize Int Int -- width, height + --deriving (Printers) + +data XRect {-# STRICT #-} = XRect Int Int Int Int -- x, y, width, height + --deriving (Printers) + +data XArc {-# STRICT #-} = XArc Int Int Int Int Float Float + --deriving (Printers) -- x, y, width, height, angle1, angle2 + +data XBitmapFormat {-# STRICT #-} = XBitmapFormat Int Int Bool + --deriving (Printers) -- unit, pad, lsb-first-p + +data XByteOrder = XLsbFirst + | XMsbFirst + --deriving (Printers) + +data XPixmapFormat {-# STRICT #-} = XPixmapFormat Int Int Int + --deriving (Printers) -- depth, bits-per-pixel, scanline-pad + +data XVisualInfo {-# STRICT #-} = XVisualInfo + Int -- id + XVisualClass -- class + XPixel -- red-mask + XPixel -- green-mask + XPixel -- blue-mask + Int -- bits-per-rgb + Int -- colormap-entries + --deriving (Printers) + +data XVisualClass = XDirectColor + | XGrayScale + | XPseudoColor + | XStaticColor + | XStaticGray + | XTrueColor + --deriving (Printers) + +data XFillContent {-# STRICT #-} + = XFillPixel XPixel + | XFillPixmap XPixmap + | XFillNone + | XFillParentRelative + | XFillCopy + --deriving (Printers) + +data XBackingStore = XAlwaysBackStore + | XNeverBackStore + | XBackStoreWhenMapped + | XBackStoreNotUseful + --deriving (Printers) + +data XGravity = XForget + | XStatic + | XCenter + | XEast + | XNorth + | XNorthEast + | XNorthWest + | XSouth + | XSouthEast + | XSouthWest + | XWest + --deriving (Printers) + +data XWindowClass = XInputOutput + | XInputOnly + --deriving (Printers) + +data XMapState = XUnmapped + | XUnviewable + | XViewable + --deriving (Printers) + +data XImageData {-# STRICT #-} + = XBitmapData [XBitmap] + | XPixarrayData XPixarray + | XByteVecData XByteVec + --deriving (Printers) + +data XImageFormat = XXyPixmapImage + | XZPixmapImage + | XBitmapImage + --deriving (Printers) + +data XImageType = XImageX + | XImageXy + | XImageZ + --deriving (Printers) + +data XDrawDirection = XLeftToRight + | XRightToLeft + --deriving (Printers) + +data XColor {-# STRICT #-} = XColor Float Float Float + --deriving (Printers) + +data XInputFocus {-# STRICT #-} + = XFocusWindow XWindow + | XFocusNone + | XFocusPointerRoot + | XFocusParent + --deriving (Printers) + +data XGrabStatus = XAlreadyGrabbed + | XFrozen + | XInvalidTime + | XNotViewable + | XSuccess + --deriving (Printers) + + +data XKeysym {-# STRICT #-} = XKeysym Integer + --deriving (Printers) + + +data XCloseDownMode = XDestroy + | XRetainPermanent + | XRetainTemporary + --deriving (Printers) + +data XScreenSaver {-# STRICT #-} = XScreenSaver Int Int Bool Bool + --deriving (Printers) + +{-# +ImportLispType ( + XMaybe (XSome ("not-null?", "identity", "identity"), + XNull ("null?", "'()")), + XError (XError ("cons-xerror", "x-error-string")), + XBitmap (XBitmap ("mk-bitmap", "sel-bitmap")), + XKeysymTable (XKeysymTable ("mk-keysym-table", "sel-keysym-table")), + XBitVec (XBitVec ("mk-bitvec", "sel-bitvec")), + XPixarray (XPixarray ("mk-pixarray", "sel-pixarray")), + XByteVec (XByteVec ("mk-bytevec", "sel-bytevec")), + XAtom (XAtom ("mk-atom", "sel-atom")), + XProperty (XProperty ("mk-xproperty", "sel-xproperty-data", + "sel-xproperty-type", "sel-xproperty-format")), + XDrawable (XDrawWindow ("xlib:window-p", "identity", "identity"), + XDrawPixmap ("xlib:pixmap-p", "identity", "identity")), + XSwitch ( XOn(":on"), XOff(":off")), + XWindowPlace (XTopPlace (":top"), XBottomPlace (":bottom")), + XEventMode (XNormalMode (":normal"), + XGrabMode (":grab"), + XUngrabMode (":ungrab"), + XWhileGrabbedMode (":while-grabbed")), + XEventKind (XAncestorKind (":ancestor"), + XVirtualKind (":virtual"), + XInferiorKind (":inferior"), + XNonlinearKind (":nonlinear"), + XNonlinearVirtualKind (":nonlinear-virtual"), + XPointerKind (":pointer"), + XPointerRootKind (":pointer-root"), + XNoneKind (":none")), + XWindowVisibility (XUnobscured (":unobscured"), + XPartiallyObscured (":partially-obscured"), + XFullyObscured (":fully-obscured")), + XWindowStackMode (XStackAbove (":above"), + XStackBelow (":below"), + XStackTopIf (":top-if"), + XStackBottomIf (":bottom-if"), + XStackOpposite (":opposite")), + XPropertyState (XNewValueProperty (":new-value"), + XDeletedProperty (":deleted")), + XMapReqType (XModifierMapping (":modifier"), + XKeyboardMapping (":keyboard"), + XPointerMapping (":pointer")), + XGraphFun (XGraphFun ("cons", "car", "cdr")), + XEvent (XEvent ("mk-event", "sel-event-type", "sel-event-slots")), + XEventType (XKeyPressEvent (":key-press"), + XKeyReleaseEvent (":key-release"), + XButtonPressEvent (":button-press"), + XButtonReleaseEvent (":button-release"), + XMotionNotifyEvent (":motion-notify"), + XEnterNotifyEvent (":enter-notify"), + XLeaveNotifyEvent (":leave-notify"), + XFocusInEvent (":focus-in"), + XFocusOutEvent (":focus-out"), + XKeymapNotifyEvent (":keymap-notify"), + XMappingNotifyEvent (":mapping-notify"), + XExposureEvent (":exposure"), + XGraphicsExposureEvent (":graphics-exposure"), + XNoExposureEvent (":no-exposure"), + XCirculateNotifyEvent (":circulate-notify"), + XConfigureNotifyEvent (":configure-notify"), + XCreateNotifyEvent (":create-notify"), + XDestroyNotifyEvent (":destroy-notify"), + XGravityNotifyEvent (":gravity-notify"), + XMapNotifyEvent (":map-notify"), + XReparentNotifyEvent (":reparent-notify"), + XUnmapNotifyEvent (":unmap-notify"), + XVisibilityNotifyEvent (":visibility-notify"), + XCirculateRequestEvent (":circulate-notify"), + XColormapNotifyEvent (":colormap-notify"), + XConfigureRequestEvent (":configure-request"), + XMapRequestEvent (":map-request"), + XResizeRequestEvent (":resize-request"), + XClientMessageEvent (":client-message"), + XPropertyNotifyEvent (":property-notify"), + XSelectionClearEvent (":selection-clear"), + XSelectionNotifyEvent (":selection-notify"), + XSelectionRequestEvent (":selection-request"), + XOtherEvents (":others")), + XEventSlot (XEventWindow ("is-window", "mk-window", "keyword-val"), + XEventEventWindow + ("is-event-window", "mk-event-window", "keyword-val"), + XEventCode ("is-code", "mk-code", "keyword-val"), + XEventPos ("is-pos", "mk-pos", "keyword-val"), + XEventState ("is-state", "mk-state", "keyword-val"), + XEventTime ("is-time", "mk-time", "keyword-val"), + XEventRoot ("is-root", "mk-root", "keyword-val"), + XEventRootPos ("is-root-pos", "mk-root-pos", "keyword-val"), + XEventChild ("is-child", "mk-child", "keyword-val"), + XEventSameScreenP + ("is-same-screen-p", "mk-same-screen-p", "keyword-val"), + XEventHintP ("is-hint-p", "mk-hint-p", "keyword-val"), + XEventMode ("is-mode", "mk-mode", "keyword-val"), + XEventKind ("is-kind", "mk-kind", "keyword-val"), + XEventFocusP ("is-focus-p", "mk-focus-p", "keyword-val"), + XEventKeymap ("is-keymap", "mk-keymap", "keyword-val"), + XEventRequest ("is-request", "mk-request", "keyword-val"), + XEventStart ("is-start", "mk-start", "keyword-val"), + XEventCount ("is-count", "mk-count", "keyword-val"), + XEventRect ("is-rect", "mk-rect", "keyword-val"), + XEventDrawable ("is-drawable", "mk-drawable", "keyword-val"), + XEventXGraphFun ("is-graph-fun", "mk-graph-fun", "keyword-val"), + XEventPlace ("is-place", "mk-place", "keyword-val"), + XEventBorderWidth + ("is-border-width", "mk-border-width", "keyword-val"), + XEventAboveSibling + ("is-above-sibling", "mk-above-sibling", "keyword-val"), + XEventOverrideRedirectP + ("is-override-redirect-p", "mk-override-redirect-p", "keyword-val"), + XEventParent ("is-parent", "mk-parent", "keyword-val"), + XEventConfigureP ("is-configure-p", "mk-configure-p", "keyword-val"), + XEventVisibility ("is-visibility", "mk-visibility", "keyword-val"), + XEventNewP ("is-new-p", "mk-new-p", "keyword-val"), + XEventInstalledP ("is-installed-p", "mk-installed-p", "keyword-val"), + XEventStackMode ("is-stack-mode", "mk-stack-mode", "keyword-val"), + XEventValueMask ("is-value-mask", "mk-value-mask", "keyword-val"), + XEventSize ("is-size", "mk-size", "keyword-val"), + XEventMessage ("is-message", "mk-message", "keyword-val"), + XEventPropertyState + ("is-property-state", "mk-property-state", "keyword-val"), + XEventAtom ("is-atom", "mk-atom", "keyword-val"), + XEventSelection ("is-selection", "mk-selection", "keyword-val"), + XEventTarget ("is-target", "mk-target", "keyword-val"), + XEventProperty ("is-property", "mk-property", "keyword-val"), + XEventRequestor ("is-requestor", "mk-requestor", "keyword-val")), + XEventMask (XEventMask ("x-make-event-mask", "x-event-mask-key-list")), + XEventMaskKey (XButton1Motion (":button-1-motion"), + XButton2Motion (":button-2-motion"), + XButton3Motion (":button-3-motion"), + XButton4Motion (":button-4-motion"), + XButton5Motion (":button-5-motion"), + XButtonMotion (":button-motion"), + XButtonPress (":button-press"), + XButtonRelease (":button-release"), + XColormapChange (":colormap-change"), + XEnterWindow (":enter-window"), + XExposure (":exposure"), + XFocusChange (":focus-change"), + XKeyPress (":key-press"), + XKeyRelease (":key-release"), + XKeymapState (":keymap-state"), + XLeaveWindow (":leave-window"), + XOwnerGrabButton (":owner-grab-button"), + XPointerMotion (":pointer-motion"), + XPointerMotionHint (":pointer-motion-hint"), + XPropertyChange (":property-change"), + XResizeRedirect (":resize-redirect"), + XStructureNotify (":structure-notify"), + XSubstructureRedirect (":substructure-notify"), + XVisibilityChange (":visibility-change")), + XStateMask (XStateMask ("x-make-state-mask", "x-state-mask-key-list")), + XStateMaskKey (XShift (":shift"), + XLock (":lock"), + XControl (":control"), + XMod1 (":mod-1"), + XMod2 (":mod-2"), + XMod3 (":mod-3"), + XMod4 (":mod-4"), + XMod5 (":mod-5"), + XButton1 (":button-1"), + XButton2 (":button-2"), + XButton3 (":button-3"), + XButton4 (":button-4"), + XButton5 (":button-5")), + XWinAttribute + (XWinBackground ("is-background","mk-background","keyword-val"), + XWinEventMask ("is-event-mask","mk-event-mask","keyword-val"), + XWinDepth ("is-depth","mk-depth","keyword-val"), + XWinBorderWidth ("is-border-width","mk-border-width","keyword-val"), + XWinClass ("is-class","mk-class","keyword-val"), + XWinVisual ("is-visual","mk-visual","keyword-val"), + XWinBorder ("is-border","mk-border","keyword-val"), + XWinBackingStore ("is-backing-store","mk-backing-store","keyword-val"), + XWinBackingPlanes ("is-backing-planes","mk-backing-planes","keyword-val"), + XWinBackingPixel ("is-backing-pixel","mk-backing-pixel","keyword-val"), + XWinSaveUnder ("is-save-under","mk-save-under","keyword-val"), + XWinDoNotPropagateMask ("is-do-not-propagate-mask", + "mk-do-not-propagate-mask","keyword-val"), + XWinOverrideRedirect("is-override-redirect", + "mk-override-redirect","keyword-val"), + XWinColormap ("is-colormap","mk-colormap","keyword-val"), + XWinCursor ("is-cursor","mk-cursor","keyword-val")), + XGCAttribute( + XGCArcMode ("is-arc-mode","mk-arc-mode","keyword-val"), + XGCBackground ("is-background","mk-background","keyword-val"), + XGCCapStyle ("is-cap-style","mk-cap-style","keyword-val"), + XGCClipMask ("is-clip-mask","mk-clip-mask","keyword-val"), + XGCClipOrigin ("is-clip-origin","mk-clip-origin","keyword-val"), + XGCDashOffset ("is-dash-offset","mk-dash-offset","keyword-val"), + XGCDashes ("is-dashes","mk-dashes","keyword-val"), + XGCExposures ("is-exposures","mk-exposures","keyword-val"), + XGCFillRule ("is-fill-rule","mk-fill-rule","keyword-val"), + XGCFillStyle ("is-fill-style","mk-fill-style","keyword-val"), + XGCFont ("is-font","mk-font","keyword-val"), + XGCForeground ("is-foreground","mk-foreground","keyword-val"), + XGCFunction ("is-function","mk-function","keyword-val"), + XGCJoinStyle ("is-join-style","mk-join-style","keyword-val"), + XGCLineStyle ("is-line-style","mk-line-style","keyword-val"), + XGCLineWidth ("is-line-width","mk-line-width","keyword-val"), + XGCPlaneMask ("is-plane-mask","mk-plane-mask","keyword-val"), + XGCStipple ("is-stipple","mk-stipple","keyword-val"), + XGCSubwindowMode ("is-subwindow-mode","mk-subwindow-mode","keyword-val"), + XGCTile ("is-tile","mk-tile","keyword-val"), + XGCTileOrigin ("is-tile-origin","mk-tile-origin","keyword-val")), + XImAttribute ( + XImBitLsbFirstP ("is-bit-lsb-first-p","mk-bit-lsb-first-p","keyword-val"), + XImBitsPerPixel ("is-bits-per-pixel","mk-bits-per-pixel","keyword-val"), + XImBlueMask ("is-blue-mask","mk-blue-mask","keyword-val"), + XImByteLsbFirstP ("is-byte-lsb-first-p","mk-byte-lsb-first-p","keyword-val"), + XImBytesPerLine ("is-bytes-per-line","mk-bytes-per-line","keyword-val"), + XImData ("is-data","mk-data","keyword-val"), + XImDepth ("is-depth","mk-depth","keyword-val"), + XImFormat ("is-format","mk-format","keyword-val"), + XImGreenMask ("is-green-mask","mk-green-mask","keyword-val"), + XImSize ("is-size","mk-size","keyword-val"), + XImName ("is-name","mk-name","keyword-val"), + XImRedMask ("is-red-mask","mk-red-mask","keyword-val"), + XImHotSpot ("is-hot-spot","mk-hot-spot","keyword-val")), + XGrabAttribute ( + XGrabOwnerP ("is-owner-p", "mk-owner-p", "keyword-val"), + XGrabSyncPointerP ("is-sync-pointer-p", "mk-sync-pointer-p", "keyword-val"), + XGrabSyncKeyboardP ("is-sync-keyboard-p", "mk-sync-keyboard-p", "keyword-val"), + XGrabConfineTo ("is-confine-to", "mk-confine-to", "keyword-val"), + XGrabCursor ("is-cursor", "mk-cursor", "keyword-val")), + XArcMode (XChord (":chord"), + XPieSlice (":pie-slice")), + XCapStyle (XButt (":butt"), + XNotLast (":not-last"), + XProjecting (":projecting"), + XRound (":round")), + XClipMask (XClipMaskPixmap ("xlib:pixmap-p","identity","identity"), + XClipMaskRects ("not-pixmap-and-list-p","mk-clip-mask-rects", + "sel-clip-mask-rects"), + XClipMaskNone ("null?", "()")), + XFillRule (XFillEvenOdd (":even-odd"), + XFillWinding (":winding")), + XFillStyle (XFillOpaqueStippled (":opaque-stippled"), + XFillSolid (":solid"), + XFillStippled (":stippled"), + XFillTiled (":tiled")), + XFunction (XBoole1 ("xlib::boole-1"), + XBoole2 ("xlib::boole-2"), + XBooleAndC1 ("xlib::boole-andc1"), + XBooleAndC2 ("xlib::boole-andc2"), + XBooleAnd ("xlib::boole-and"), + XBooleC1 ("xlib::boole-c1"), + XBooleC2 ("xlib::boole-c2"), + XBooleClr ("xlib::boole-clr"), + XBooleEqv ("xlib::boole-eqv"), + XBooleIor ("xlib::boole-ior"), + XBooleNand ("xlib::boole-nand"), + XBooleNor ("xlib::boole-nor"), + XBooleOrc1 ("xlib::boole-orc1"), + XBooleOrc2 ("xlib::boole-orc2"), + XBooleSet ("xlib::boole-set"), + XBooleXor ("xlib::boole-xor")), + XJoinStyle (XJoinBevel (":bevel"), + XJoinMiter (":miter"), + XJoinRound (":round")), + XLineStyle (XLineSolid (":solid"), + XLineDoubleDash (":double-dash"), + XLineOnOffDash (":on-off-dash")), + XSubwindowMode (XClipByChildren (":clip-by-children"), + XIncludeInferiors (":include-inferiors")), + XPoint(XPoint("mk-xpoint", "xpoint-x", "xpoint-y")), + XSize (XSize ("mk-xsize", "xsize-w", "xsize-h")), + XRect (XRect ("mk-xrect", "xrect-x", "xrect-y", "xrect-w", "xrect-h")), + XArc (XArc ("mk-xarc", "xarc-x", "xarc-y", "xarc-w", "xarc-h", + "xarc-a1", "xarc-a2")), + XBitmapFormat + (XBitmapFormat ("bitmap-format-p", "mk-bitmap-format", + "xlib:bitmap-format-unit", + "xlib:bitmap-format-pad", + "xlib:bitmap-format-lsb-first-p")), + XByteOrder (XLsbFirst (":lsbfirst"), + XMsbFirst (":msbfirst")), + XPixmapFormat (XPixmapFormat ("pixmap-format-p", "mk-pixmap-format", + "xlib:pixmap-format-depth", + "xlib:pixmap-format-bits-per-pixel", + "xlib:pixmap-format-scanline-pad")), + XVisualInfo + (XVisualInfo ( "visual-info-p", "mk-xvisual-info", + "xlib:visual-info-id", + "xlib:visual-info-class", + "xlib:visual-info-red-mask", + "xlib:visual-info-green-mask", + "xlib:visual-info-blue-mask", + "xlib:visual-info-bits-per-rgb", + "xlib:visual-info-colormap-entries")), + XVisualClass (XDirectColor (":direct-color"), + XGrayScale (":gray-scale"), + XPseudoColor (":pseudo-color"), + XStaticColor (":static-color"), + XStaticGray (":static-gray"), + XTrueColor (":true-color")), + XFillContent (XFillPixel ("is-fill-pixel", "identity","identity"), + XFillPixmap ("xlib:pixmap-p", "identity","identity"), + XFillNone (":none"), + XFillParentRelative (":parent-relative"), + XFillCopy (":copy")), + XBackingStore (XAlwaysBackStore (":always"), + XNeverBackStore (":never"), + XBackStoreWhenMapped (":when-mapped"), + XBackStoreNotUseful (":not-useful")), + XGravity (XForget (":forget"), + XStatic (":static"), + XCenter (":center"), + XEast (":east"), + XNorth (":north"), + XNorthEast (":north-east"), + XNorthWest (":north-west"), + XSouth (":south"), + XSouthEast (":south-east"), + XSouthWest (":south-west"), + XWest ("west")), + XWindowClass (XInputOutput (":input-output"), + XInputOnly (":input-only")), + XMapState (XUnmapped (":unmapped"), + XUnviewable (":unviewable"), + XViewable (":viewable")), + XImageData (XBitmapData ("bitmap-list-p", "haskell-list->list/identity", "list->haskell-list/identity"), + XPixarrayData ("pixarray-p", "identity", "identity"), + XByteVecData ("bytevec-p", "identity", "identity")), + XImageFormat (XXyPixmapImage (":xy-pixmap"), + XZPixmapImage (":z-pixmap"), + XBitmapImage (":bitmap")), + XImageType (XImageX ("'xlib:image-x"), + XImageXy ("'xlib:image-xy"), + XImageZ ("'xlib:image-z")), + XDrawDirection (XLeftToRight (":left-to-right"), + XRightToLeft (":right-to-left")), + XColor (XColor ("xlib:color-p", "mk-color", + "xlib:color-red", "xlib:color-green", "xlib:color-blue")), + XInputFocus (XFocusWindow ("xlib:window-p", "identity", "identity"), + XFocusNone (":none"), + XFocusPointerRoot (":pointer-root"), + XFocusParent (":parent")), + XGrabStatus (XAlreadyGrabbed (":already-grabbed"), + XFrozen (":frozen"), + XInvalidTime (":invalid-time"), + XSuccess (":success")), + XCloseDownMode (XDestroy (":destroy"), + XRetainPermanent (":retain-permanent"), + XRetainTemporary (":retain-temporary")), + XScreenSaver (XScreenSaver ("list", "car", "cadr", "caddr", "cadddr"))) + +#-} + diff --git a/progs/lib/X11/xlib.hu b/progs/lib/X11/xlib.hu new file mode 100644 index 0000000..b86b2ac --- /dev/null +++ b/progs/lib/X11/xlib.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:stable +:o= all +xlib.hs +xlibprims.hu diff --git a/progs/lib/X11/xlibclx.scm b/progs/lib/X11/xlibclx.scm new file mode 100644 index 0000000..1f1fd6a --- /dev/null +++ b/progs/lib/X11/xlibclx.scm @@ -0,0 +1,1262 @@ +;;; xlibclx.scm -- Lisp support for Haskell/CLX interface + +;; general + +(define-syntax (nth-value n form) + (cond ((eqv? n 0) + `(values ,form)) + ((number? n) + (let ((temps '())) + (dotimes (i n) + (declare (ignorable i)) + (push (gensym) temps)) + `(multiple-value-bind ,(reverse temps) ,form + (declare (ignore ,@(reverse (cdr temps)))) + ,(car temps)))) + (else + `(lisp:nth ,n (lisp:multiple-value-list ,form))) + )) + + +(define-local-syntax (keywordify string) + `(lisp:intern ,string (lisp:find-package "KEYWORD"))) + +(define-local-syntax (xlibify string) + `(lisp:intern ,string (lisp:find-package "XLIB"))) + + + +;;; This is stuff to support slots that consist of a keyword/value +;;; pair. Note that the value is always unboxed. + +(define-syntax (make-keyword key value) + `(cons ,key ,value)) + +(define-syntax (is-keyword? x key) + `(eq? (car ,x) ,key)) + +(define-syntax (keyword-key x) `(car ,x)) +(define-syntax (keyword-val x) `(cdr ,x)) + +(define-syntax (define-keyword-constructor name) + (let* ((name-str (symbol->string name)) + (key (keywordify name-str)) + (is-name (string->symbol (string-append "IS-" name-str))) + (mk-name (string->symbol (string-append "MK-" name-str)))) + `(begin + (define (,mk-name x) (make-keyword ,key x)) + (define (,is-name x) (is-keyword? x ,key))) + )) + +(define-syntax (define-event-slot-finder slot) + (let* ((slot-str (symbol->string slot)) + (slot-key (keywordify slot-str)) + (fun (string->symbol (string-append "X-EVENT-" slot-str)))) + `(define (,fun event) (lookup-event-slot (cdr event) ,slot-key)))) + +(define (lookup-event-slot event key) + (if (null? event) + (error "non-existent event slot: ~A" key) + (if (eq? key (car event)) + (cadr event) + (lookup-event-slot (cddr event) key)))) + + +(define-syntax (define-attribute-setter entity attribute) + (let* ((entity-attr (string-append (symbol->string entity) + "-" + (symbol->string attribute))) + (fun-name (string->symbol (string-append "X-SET-" entity-attr))) + (xfun-name (xlibify entity-attr))) + `(define (,fun-name ,entity ,attribute) + (setf (,xfun-name ,entity) ,attribute)))) + +(define-syntax (make-h-tuple . args) + (let ((nargs (map (lambda (arg) `(box ,arg)) args))) + `(make-tuple ,@nargs))) + +;; type XError + +(define (cons-xerror x) + (declare (ignore x)) + (error "can't construct XError")) + +(define (x-error-string c) + (make-haskell-string (format '#f "~A" c))) + + +;;; The forces here are necessary because the thing being funcalled +;;; returns a data structure of type (IO a), and we need to do +;;; an IO a -> a transformation. + +#+lucid +(define (x-handle-error handler body) + (lisp:catch 'x-error-handle + (lcl:handler-bind ((lisp:error (mk-handler handler))) + (force (funcall body (box 'state)))))) + +#+(or cmu allegro lispworks) +(define (x-handle-error handler body) + (lisp:catch 'x-error-handle + (lisp:handler-bind ((lisp:error (mk-handler handler))) + (force (funcall body (box 'state)))))) + +#+akcl +(define (x-handle-error handler body) + (error "AKCL does not support HANDLER-BIND!")) + +(define (mk-handler handler) + (lambda (c) + (lisp:throw 'x-error-handle + (force (funcall handler + (box c) + (box 'state)))))) + +;; for type XMaybe + +(define (not-null? x) (not (null? x))) + + +;; For Bitmap, Pixarray, KeysymTable + +(define (array2->haskell-list a) + (let* ((dims (lisp:array-dimensions a)) + (i1max (car dims)) + (i2max (cadr dims))) + (declare (type fixnum i1max i2max)) + (do ((i1 (the fixnum (1- i1max)) (the fixnum (1- i1))) + (outer '())) + ((< i1 0) outer) + (declare (type fixnum i1)) + (setf outer + (cons + (box + (do ((i2 (the fixnum (1- i2max)) (the fixnum (1- i2))) + (inner '())) + ((< i2 0) inner) + (declare (type fixnum i2)) + (setf inner + (cons (box (lisp:aref a i1 i2)) + (box inner))))) + (box outer)))) + )) + + +;; Bitmap + +(define (mk-bitmap ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type 'lisp:bit + :initial-contents l))) + +(define (sel-bitmap l) + (array2->haskell-list l)) + + +;; XKeysymTable + +(define (mk-keysym-table ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type 'xlib:card32 + :initial-contents l))) + +(define (sel-keysym-table l) + (array2->haskell-list l)) + +;; XPixarray + +(define (mk-pixarray ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (let* ((max-num (find-max l)) + (pix-type (cond ((<= max-num 1) 'lisp:bit) + ((<= max-num 15) '(lisp:unsigned-byte 4)) + ((<= max-num 255) 'xlib:card8) + ((<= max-num 65535) 'xlib:card16) + (else 'xlib:card32)))) + (declare (type integer max-num)) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type pix-type + :initial-contents l)))) + +(define (find-max l) + (let ((max 0)) + (dolist (ll l) + (dolist (lll ll) + (when (> (the integer lll) (the integer max)) + (setf max lll)))) + max)) + +(define (sel-pixarray l) + (array2->haskell-list l)) + + + + +;;; Can't use mumble vector primitives on arrays of specialized types! + +(define (array1->haskell-list a) + (declare (type lisp:vector a)) + (let ((imax (lisp:length a))) + (declare (type fixnum imax)) + (do ((i (the fixnum (1- imax)) (the fixnum (1- i))) + (result '())) + ((< i 0) result) + (declare (type fixnum i)) + (setf result + (cons (box (lisp:aref a i)) + (box result)))))) + +;; BitVec + +(define (mk-bitvec ll) + (let ((l (haskell-list->list/identity ll))) + (lisp:make-array `(,(length l)) :element-type 'lisp:bit + :initial-contents l))) + +(define (sel-bitvec l) + (array1->haskell-list l)) + +;; ByteVec + +(define (mk-bytevec ll) + (let ((l (haskell-list->list/identity ll))) + (lisp:make-array `(,(length l)) :element-type 'xlib:card8 + :initial-contents l))) + +(define (sel-bytevec l) + (array1->haskell-list l)) + + +;; XAtom +(define (mk-atom name) + (keywordify (haskell-string->string name))) + +(define (sel-atom atom) + (make-haskell-string (symbol->string atom))) + +;; XProperty +;;; watch out for name conflict with :property keyword stuff +(define (mk-xproperty d ty f) (list (haskell-list->list/identity d) ty f)) +(define (sel-xproperty-data p) (list->haskell-list/identity (car p))) +(define (sel-xproperty-type p) (cadr p)) +(define (sel-xproperty-format p) (caddr p)) + +(define (mk-event type slots) + (cons type (slots->keywords (haskell-list->list/identity slots)))) + +(define (sel-event-type event) (car event)) + +(define (sel-event-slots event) + (list->haskell-list/identity (keywords->slots (car event) (cdr event) event))) + +;; XEventSlot + +(define-keyword-constructor window) +(define-keyword-constructor event-window) +(define-keyword-constructor code) +(define-keyword-constructor pos) +(define-keyword-constructor state) +(define-keyword-constructor time) +(define-keyword-constructor root) +(define-keyword-constructor root-pos) +(define-keyword-constructor child) +(define-keyword-constructor same-screen-p) +(define-keyword-constructor hint-p) +(define-keyword-constructor mode) +(define-keyword-constructor kind) +(define-keyword-constructor focus-p) +(define-keyword-constructor keymap) +(define-keyword-constructor request) +(define-keyword-constructor start) +(define-keyword-constructor count) +(define-keyword-constructor rect) +(define-keyword-constructor drawable) +(define-keyword-constructor graph-fun) +(define-keyword-constructor place) +(define-keyword-constructor border-width) +(define-keyword-constructor above-sibling) +(define-keyword-constructor override-redirect-p) +(define-keyword-constructor parent) +(define-keyword-constructor configure-p) +(define-keyword-constructor visibility) +(define-keyword-constructor new-p) +(define-keyword-constructor installed-p) +(define-keyword-constructor stack-mode) +(define-keyword-constructor value-mask) +(define-keyword-constructor size) +(define-keyword-constructor message) +(define-keyword-constructor property-state) +(define-keyword-constructor atom) +(define-keyword-constructor selection) +(define-keyword-constructor target) +(define-keyword-constructor property) +(define-keyword-constructor requestor) + +(define-event-slot-finder window) +(define-event-slot-finder event-window) +(define-event-slot-finder code) +(define-event-slot-finder x) +(define-event-slot-finder y) +(define-event-slot-finder state) +(define-event-slot-finder time) +(define-event-slot-finder root) +(define-event-slot-finder root-x) +(define-event-slot-finder root-y) +(define-event-slot-finder child) +(define-event-slot-finder same-screen-p) +(define-event-slot-finder hint-p) +(define-event-slot-finder mode) +(define-event-slot-finder kind) +(define-event-slot-finder focus-p) +(define-event-slot-finder keymap) +(define-event-slot-finder request) +(define-event-slot-finder start) +(define-event-slot-finder count) +(define-event-slot-finder width) +(define-event-slot-finder height) +(define-event-slot-finder drawable) +(define-event-slot-finder major) +(define-event-slot-finder minor) +(define-event-slot-finder place) +(define-event-slot-finder border-width) +(define-event-slot-finder above-sibling) +(define-event-slot-finder override-redirect-p) +(define-event-slot-finder parent) +(define-event-slot-finder configure-p) +(define-event-slot-finder new-p) +(define-event-slot-finder installed-p) +(define-event-slot-finder stack-mode) +(define-event-slot-finder value-mask) +(define-event-slot-finder data) +(define-event-slot-finder type) +(define-event-slot-finder format) +(define-event-slot-finder atom) +(define-event-slot-finder selection) +(define-event-slot-finder target) +(define-event-slot-finder property) +(define-event-slot-finder requestor) + +(define (x-event-pos event) (mk-xpoint (x-event-x event) (x-event-y event))) + +(define (x-event-root-pos event) + (mk-xpoint (x-event-root-x event) (x-event-root-y event))) + +(define (x-event-size event) + (mk-xsize (x-event-width event) (x-event-height event))) + +(define (x-event-rect event) + (mk-xrect (x-event-x event) (x-event-y event) + (x-event-width event) (x-event-height event))) + +(define (x-event-graph-fun event) + (cons (x-event-major event) (x-event-minor event))) + +(define (x-event-message event) + (list (sequence->list (x-event-data event)) + (x-event-type event) + (x-event-format event))) + + +;; XEventMask + +(define (x-make-event-mask keys) + (apply (function xlib:make-event-mask) (haskell-list->list/identity keys))) + +(define (x-event-mask-key-list mask) + (list->haskell-list/identity (xlib:make-event-keys mask))) + +;; XStateMask + +(define (x-make-state-mask keys) + (apply (function xlib:make-state-mask) (haskell-list->list/identity keys))) + +(define (x-state-mask-key-list mask) + (list->haskell-list/identity (xlib:make-state-keys mask))) + + +(define-keyword-constructor background) +(define-keyword-constructor foreground) +(define-keyword-constructor event-mask) +(define-keyword-constructor depth) +(define-keyword-constructor border-width) +(define-keyword-constructor class) +(define-keyword-constructor visual) +(define-keyword-constructor border) +(define-keyword-constructor backing-store) +(define-keyword-constructor backing-planes) +(define-keyword-constructor backing-pixel) +(define-keyword-constructor save-under) +(define-keyword-constructor do-not-propagate-mask) +(define-keyword-constructor override-redirect) +(define-keyword-constructor colormap) +(define-keyword-constructor cursor) + +(define-keyword-constructor arc-mode) +(define-keyword-constructor cap-style) +(define-keyword-constructor clip-mask) +(define-keyword-constructor clip-origin) +(define-keyword-constructor dash-offset) +(define-keyword-constructor dashes) +(define-keyword-constructor exposures) +(define-keyword-constructor fill-rule) +(define-keyword-constructor fill-style) +(define-keyword-constructor font) +(define-keyword-constructor function) +(define-keyword-constructor join-style) +(define-keyword-constructor line-style) +(define-keyword-constructor line-width) +(define-keyword-constructor plane-mask) +(define-keyword-constructor stipple) +(define-keyword-constructor subwindow-mode) +(define-keyword-constructor tile) +(define-keyword-constructor tile-origin) + +(define-keyword-constructor bit-lsb-first-p) +(define-keyword-constructor bits-per-pixel) +(define-keyword-constructor blue-mask) +(define-keyword-constructor byte-lsb-first-p) +(define-keyword-constructor bytes-per-line) +(define-keyword-constructor data) +(define-keyword-constructor format) +(define-keyword-constructor green-mask) +(define-keyword-constructor size) +(define-keyword-constructor name) +(define-keyword-constructor red-mask) +(define-keyword-constructor hot-spot) + + +(define-keyword-constructor owner-p) +(define-keyword-constructor sync-pointer-p) +(define-keyword-constructor sync-keyboard-p) +(define-keyword-constructor confine-to) + + +;; XClipMask + +(define (not-pixmap-and-list-p x) + (and (pair? x) (not (xlib:pixmap-p x)))) +(define (mk-clip-mask-rects rects) + (rects->point-seq (haskell-list->list/identity rects))) +(define (sel-clip-mask-rects point-seq) + (list->haskell-list/identity (point-seq->rects point-seq))) + +;; XPoint + +(define (mk-xpoint x y) (cons x y)) +(define (xpoint-x x) (car x)) +(define (xpoint-y x) (cdr x)) + +;; XSize + +(define (mk-xsize x y) (cons x y)) +(define (xsize-w x) (car x)) +(define (xsize-h x) (cdr x)) + +;; XRect +(define (mk-xrect x y w h) (vector x y w h)) +(define (xrect-x x) (vector-ref x 0)) +(define (xrect-y x) (vector-ref x 1)) +(define (xrect-w x) (vector-ref x 2)) +(define (xrect-h x) (vector-ref x 3)) + +;; XArc + +(define (mk-xarc x y w h a1 a2) (vector x y w h a1 a2)) + +(define (xarc-x x) (vector-ref x 0)) +(define (xarc-y x) (vector-ref x 1)) +(define (xarc-w x) (vector-ref x 2)) +(define (xarc-h x) (vector-ref x 3)) +(define (xarc-a1 x) (vector-ref x 4)) +(define (xarc-a2 x) (vector-ref x 5)) + +;; BitmapFormat + +(define (mk-bitmap-format u p l) + (xlib::make-bitmap-format :unit u :pad p :lsb-first-p l)) + +;; PixmapFormat + +(define (mk-pixmap-format u p l) + (xlib::make-pixmap-format :depth u :bits-per-pixel p :scanline-pad l)) + +;; XVisualInfo + +(define (mk-xvisual-info id cl rm gm bm bs es) + (xlib::make-visual-info :id id :class cl :red-mask rm :green-mask gm + :blue-mask bm :bits-per-rgb bs :colormap-entries es)) + +;; XFillContent + +(define (is-fill-pixel x) (not (or (xlib:pixmap-p x) (symbol? x)))) + +;; XBackingStore + +;; XImageData + +(define (bitmap-list-p x) (pair? x)) +(define (pixarray-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 2))) +(define (bytevec-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 1))) + +;; XColor +(define (mk-color r g b) + (xlib:make-color :red r :green g :blue b)) + + +(define (x-print x) + (print x)) + +(define (x-set-event-mask-key mask key-sym) + (lisp:logior mask (xlib:make-event-mask key-sym))) + +(define (x-clear-event-mask-key mask key-sym) + (lisp:logand mask (lisp:lognot (xlib:make-event-mask key-sym)))) + + +(define (x-test-event-mask-key mask key-sym) + (if (eqv? 0 (lisp:logand mask (xlib:make-event-mask key-sym))) '#f '#t)) + +(define (x-set-state-mask-key mask key-sym) + (lisp:logior mask (xlib:make-state-mask key-sym))) + +(define (x-clear-state-mask-key mask key-sym) + (lisp:logand mask (lisp:lognot (xlib:make-state-mask key-sym)))) + +(define (x-test-state-mask-key mask key-sym) + (if (eqv? 0 (lisp:logand mask (xlib:make-state-mask key-sym))) '#f '#t)) + + +;;; Display is a string of the format name:d.s +;;; ignore s; if d is omitted, default it to zero. + +(define (x-open-display display) + (let* ((end (string-length display)) + (colon (or (string-position #\: display 0 end) end)) + (dot (or (string-position #\. display colon end) end))) + (declare (type fixnum end colon dot)) + (xlib:open-display + (substring display 0 colon) + :display (if (eqv? colon dot) + 0 + (string->number (substring display (1+ colon) dot)))))) + +(define (x-set-display-error-handler display error-fun) + (declare (ignore display error-fun)) + (error "not implemented")) + +(define (x-set-display-after-function display after-fun) + (declare (ignore display after-fun)) + (error "not implemented")) + +(define (x-screen-depths screen) + (let ((depths (xlib:screen-depths screen))) + (map (lambda (l) (make-h-tuple (car l) (list->haskell-list/identity (cdr l)))) + depths))) + +(define (x-screen-size screen) + (mk-xsize (xlib:screen-width screen) (xlib:screen-height screen))) + +(define (x-screen-mmsize screen) + (mk-xsize (xlib:screen-width-in-millimeters screen) + (xlib:screen-height-in-millimeters screen))) + +(define (x-create-window parent rect attrs) + (apply (function XLIB:CREATE-WINDOW) + `(:parent ,parent :x ,(xrect-x rect) :y ,(xrect-y rect) + :width ,(xrect-w rect) :height ,(xrect-h rect) + ,@(attrs->keywords attrs)))) + +(define-attribute-setter drawable border-width) + +(define (x-drawable-size drawable) + (mk-xsize (xlib:drawable-width drawable) (xlib:drawable-height drawable))) + +(define (x-drawable-resize drawable size) + (setf (xlib:drawable-width drawable) (xsize-w size)) + (setf (xlib:drawable-height drawable) (xsize-h size))) + +(define (x-window-pos window) + (mk-xpoint (xlib:drawable-x window) (xlib:drawable-y window))) + +(define (x-window-move window point) + (setf (xlib:drawable-x window) (xpoint-x point)) + (setf (xlib:drawable-y window) (xpoint-y point))) + +(define-attribute-setter window background) +(define-attribute-setter window backing-pixel) +(define-attribute-setter window backing-planes) +(define-attribute-setter window backing-store) +(define-attribute-setter window bit-gravity) +(define-attribute-setter window border) +(define-attribute-setter window colormap) + +(define (x-set-window-cursor window cursor) + (let ((val (if (null? cursor) :none cursor))) + (setf (xlib:window-cursor window) val))) + +(define-attribute-setter window do-not-propagate-mask) +(define-attribute-setter window event-mask) +(define-attribute-setter window gravity) +(define-attribute-setter window override-redirect) +(define-attribute-setter window priority) +(define-attribute-setter window save-under) + +(define (x-query-tree window) + (multiple-value-bind (children parent root) + (xlib:query-tree window) + (make-h-tuple (list->haskell-list/identity children) parent root))) + +(define (x-reparent-window window parent point) + (xlib:reparent-window window parent (xpoint-x point) (xpoint-y point))) + +(define (x-translate-coordinates source point dest) + (xlib:translate-coordinates source (xpoint-x point) (xpoint-y point) dest)) + +(define (x-create-pixmap size depth drawable) + (xlib:create-pixmap :width (xsize-w size) + :height (xsize-h size) + :depth depth + :drawable drawable)) + +(define (x-create-gcontext drawable attrs) + (apply (function XLIB:CREATE-GCONTEXT) + `(:drawable ,drawable ,@(attrs->keywords attrs)))) + +(define (x-update-gcontext gcontext attrs) + (do ((keys (attrs->keywords attrs) (cddr keys))) + ((null? keys)) + (x-update-gcontext-attr gcontext (car keys) (cadr keys)))) + +(define (x-update-gcontext-attr gcontext key attr) + (case key + (:arc-mode (setf (xlib:gcontext-arc-mode gcontext) attr)) + (:background (setf (xlib:gcontext-background gcontext) attr)) + (:cap-style (setf (xlib:gcontext-cap-style gcontext) attr)) + (:fill-style (setf (xlib:gcontext-fill-style gcontext) attr)) + (:clip-mask (setf (xlib:gcontext-clip-mask gcontext) attr)) + (:clip-x (setf (xlib:gcontext-clip-x gcontext) attr)) + (:clip-y (setf (xlib:gcontext-clip-y gcontext) attr)) + (:dash-offset (setf (xlib:gcontext-dash-offset gcontext) attr)) + (:dashes (setf (xlib:gcontext-dashes gcontext) attr)) + (:exposures (setf (xlib:gcontext-exposures gcontext) attr)) + (:fill-rule (setf (xlib:gcontext-fill-rule gcontext) attr)) + (:font (setf (xlib:gcontext-font gcontext) attr)) + (:foreground (setf (xlib:gcontext-foreground gcontext) attr)) +; (:function (setf (xlib:gcontext-function gcontext) attr)) + (:join-style (setf (xlib:gcontext-join-style gcontext) attr)) + (:line-style (setf (xlib:gcontext-line-style gcontext) attr)) +; (:line-width (setf (xlib:gcontext-line-width gcontext) attr)) +; (:plane-mask (setf (xlib:gcontext-plane-mask gcontext) attr)) +; (:stipple (setf (xlib:gcontext-stipple gcontext) attr)) + (:subwindow-mode (setf (xlib:gcontext-subwindow-mode gcontext) attr)) +; (:tile (setf (xlib:gcontext-tile gcontext) attr)) +; (:ts-x (setf (xlib:gcontext-ts-x gcontext) attr)) +; (:ts-y (setf (xlib:gcontext-ts-y gcontext) attr)) + (else (format '#t "Graphics context attribute ~A is not settable.~%" + key)))) + +(define (x-query-best-stipple dsize drawable) + (multiple-value-bind (w h) + (xlib:query-best-stipple (xsize-w dsize) (xsize-h dsize) drawable) + (mk-xsize w h))) + +(define (x-query-best-tile dsize drawable) + (multiple-value-bind (w h) + (xlib:query-best-tile (xsize-w dsize) (xsize-h dsize) drawable) + (mk-xsize w h))) + +(define (x-clear-area window rect exposures-p) + (xlib:clear-area window + :x (xrect-x rect) + :y (xrect-y rect) + :width (xrect-w rect) + :height (xrect-h rect) + :exposures-p exposures-p)) + +(define (x-copy-area src gcontext rect dest point) + (xlib:copy-area src + gcontext + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + dest + (xpoint-x point) (xpoint-y point))) + +(define (x-copy-plane src gcontext plane rect dest point) + (xlib:copy-plane src + gcontext + plane + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + dest + (xpoint-x point) (xpoint-y point))) + +(define (x-draw-point drawable gcontext point) + (xlib:draw-point drawable gcontext (xpoint-x point) (xpoint-y point))) + +(define (x-draw-points drawable gcontext points) + (xlib:draw-points drawable gcontext (points->point-seq points))) + +(define (points->point-seq points) + (if (null? points) + '() + (let ((point (car points))) + (lisp:list* (xpoint-x point) + (xpoint-y point) + (points->point-seq (cdr points)))))) + +(define (segments->point-seq segments) + (if (null? segments) + '() + (let* ((first-pair (car segments)) + (point-1 (force (tuple-select 2 0 first-pair))) + (point-2 (force (tuple-select 2 1 first-pair)))) + (lisp:list* (xpoint-x point-1) + (xpoint-y point-1) + (xpoint-x point-2) + (xpoint-y point-2) + (segments->point-seq (cdr segments)))))) + +(define (rects->point-seq rects) + (if (null? rects) + '() + (let ((rect (car rects))) + (lisp:list* (xrect-x rect) + (xrect-y rect) + (xrect-w rect) + (xrect-h rect) + (rects->point-seq (cdr rects)))))) + +(define (point-seq->rects point-seq) + (if (null? point-seq) + '() + (cons (mk-xrect (car point-seq) (cadr point-seq) + (caddr point-seq) (cadddr point-seq)) + (point-seq->rects (cddddr point-seq))))) + +(define (arcs->point-seq arcs) + (if (null? arcs) + '() + (let ((arc (car arcs))) + (lisp:list* (xarc-x arc) + (xarc-y arc) + (xarc-w arc) + (xarc-h arc) + (xarc-a1 arc) + (xarc-a2 arc) + (arcs->point-seq (cdr arcs)))))) + +(define (x-draw-line drawable gcontext point-1 point-2) + (xlib:draw-line drawable gcontext (xpoint-x point-1) (xpoint-y point-1) + (xpoint-x point-2) (xpoint-y point-2))) + +(define (x-draw-lines drawable gcontext points fill-p) + (xlib:draw-lines drawable gcontext + (points->point-seq points) :fill-p fill-p)) + +(define (x-draw-segments drawable gcontext segments) + (xlib:draw-segments drawable gcontext (segments->point-seq segments))) + +(define (x-draw-rectangle drawable gcontext rect fill-p) + (xlib:draw-rectangle drawable gcontext + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + fill-p)) + +(define (x-draw-rectangles drawable gcontext rects fill-p) + (xlib:draw-rectangles drawable gcontext + (rects->point-seq rects) + fill-p)) + +(define (x-draw-arc drawable gcontext arc fill-p) + (xlib:draw-arc drawable gcontext + (xarc-x arc) (xarc-y arc) + (xarc-w arc) (xarc-h arc) + (xarc-a1 arc) (xarc-a2 arc) + fill-p)) + +(define (x-draw-arcs drawable gcontext arcs fill-p) + (xlib:draw-arcs drawable gcontext + (arcs->point-seq arcs) + fill-p)) + +(define (x-draw-glyph drawable gcontext point element) + (nth-value 1 + (xlib:draw-glyph drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-glyphs drawable gcontext point element) + (nth-value 1 (xlib:draw-glyphs drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-image-glyph drawable gcontext point element) + (nth-value 1 (xlib:draw-image-glyph drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-image-glyphs drawable gcontext point element) + (nth-value 1 (xlib:draw-image-glyphs drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-image-size image) + (mk-xsize (xlib:image-width image) (xlib:image-height image))) + +(define (x-image-name image) + (let ((lisp-name (xlib:image-name image))) + (cond ((null? lisp-name) "") + ((symbol? lisp-name) (symbol->string lisp-name)) + (else lisp-name)))) + +(define-attribute-setter image name) + +(define (x-image-hot-spot image) + (mk-xpoint (xlib:image-x-hot image) (xlib:image-y-hot image))) + +(define (x-set-image-hot-spot image point) + (setf (xlib:image-x-hot image) (xpoint-x point)) + (setf (xlib:image-y-hot image) (xpoint-y point))) + +(define-attribute-setter image xy-bitmap-list) +(define-attribute-setter image z-bits-per-pixel) +(define-attribute-setter image z-pixarray) + +(define (x-create-image attrs) + (apply (function xlib:create-image) (attrs->keywords attrs))) + +(define (x-copy-image image rect type) + (xlib:copy-image image :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :result-type type)) + +(define (x-get-image drawable rect pmask format type) + (xlib:get-image drawable :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :plane-mask pmask :format format :result-type type)) + +(define (x-put-image drawable gcontext image point rect) + (xlib:put-image drawable gcontext image + :src-x (xpoint-x point) :src-y (xpoint-y point) + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect))) + +(define (x-get-raw-image drawable rect pmask format) + (xlib:get-raw-image drawable + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :plane-mask pmask :format format)) + +(define (x-put-raw-image drawable gcontext data depth rect left-pad format) + (xlib:put-raw-image drawable gcontext data + :depth depth + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :left-pad left-pad :format format)) + +(define (x-font-name font) + (let ((lisp-name (xlib:font-name font))) + (cond ((null? lisp-name) "") + ((symbol? lisp-name) (symbol->string lisp-name)) + (else lisp-name)))) + +(define (x-alloc-color colormap color) + (multiple-value-bind (pixel screen-color exact-color) + (xlib:alloc-color colormap color) + (make-h-tuple pixel screen-color exact-color))) + +(define (x-alloc-color-cells colormap colors planes contiguous-p) + (multiple-value-bind (pixels mask) + (xlib:alloc-color-cells colormap colors :planes planes + :contiguous-p contiguous-p) + (make-h-tuple (list->haskell-list/identity pixels) (list->haskell-list/identity mask)))) + +(define (x-alloc-color-planes colormap colors reds greens blues contiguous-p) + (multiple-value-bind (pixels red-mask green-mask blue-mask) + (xlib:alloc-color-planes colormap colors :reds reds :greens greens + :blues blues :contiguous-p contiguous-p) + (make-h-tuple (list->haskell-list/identity pixels) + red-mask + green-mask + blue-mask))) + +(define (x-lookup-color colormap name) + (multiple-value-bind (screen-color exact-color) + (xlib:lookup-color colormap name) + (make-h-tuple screen-color exact-color))) + +(define (unzip l) + (if (null? l) + '() + (let ((h (car l))) + (lisp:list* (force (tuple-select 2 0 h)) + (force (tuple-select 2 1 h)) + (unzip (cdr l)))))) + +(define (x-store-colors colormap pixel-colors) + (xlib:store-colors colormap (unzip pixel-colors))) + +(define (x-create-cursor source mask point foreground background) + (apply (function xlib:create-cursor) + `(:source ,source + ,@(if mask `(:mask ,mask) '()) + :x ,(xpoint-x point) :y ,(xpoint-y point) + :foreground ,foreground :background ,background))) + +(define (x-create-glyph-cursor src mask foreground background) + (apply (function xlib:create-glyph-cursor) + `(:source-font ,(force (tuple-select 2 0 src)) + :source-char ,(integer->char (force (tuple-select 2 1 src))) + ,@(if mask + `(:mask-font ,(force (tuple-select 2 0 mask)) + :mask-char ,(integer->char (force (tuple-select 2 1 mask)))) + '()) + :foreground ,foreground :background ,background))) + +(define (x-query-best-cursor size display) + (multiple-value-bind (w h) + (xlib:query-best-cursor (xsize-w size) (xsize-h size) display) + (mk-xsize w h))) + +(define (x-change-property window property content) + (xlib:change-property window property + (car content) (cadr content) + (caddr content))) + +(define (x-get-property window property) + (lisp:multiple-value-bind (data type format) + (xlib:get-property window property) + (list (sequence->list data) type format))) + +(define (x-convert-selection selection type requestor property time) + (apply (function xlib:convert-selection) + `(,selection ,type ,requestor ,property ,@(if time `(,time) '())))) + +(define (x-set-selection-owner display selection time owner) + (if time + (setf (xlib:selection-owner display selection time) owner) + (setf (xlib:selection-owner display selection) owner))) + +(define (sequence->list seq) + (if (list? seq) seq + (do ((i (1- (lisp:length seq)) (1- i)) + (res '() (cons (lisp:elt seq i) res))) + ((< i 0) res)))) + +(define *this-event* '()) + +(define (translate-event lisp:&rest event-slots lisp:&key event-key + lisp:&allow-other-keys) + (setf *this-event* (cons event-key event-slots)) + '#t) + + +(define (x-get-event display) + (xlib:process-event display :handler #'translate-event :force-output-p '#t) + *this-event*) + +(define (x-queue-event display event append-p) + (apply (function xlib:queue-event) + `(,display ,(car event) ,@(cdr event) :append-p ,append-p))) + +(define (x-event-listen display) + (let ((res (xlib:event-listen display))) + (if (null? res) 0 res))) + +(define (x-send-event window event mask) + (apply (function xlib:send-event) + `(,window ,(car event) ,mask ,@(cdr event)))) + +(define (x-global-pointer-position display) + (multiple-value-bind (x y) (xlib:global-pointer-position display) + (mk-xpoint x y))) + +(define (x-pointer-position window) + (multiple-value-bind (x y same) (xlib:pointer-position window) + (if same (mk-xpoint x y) '()))) + +(define (x-motion-events window start stop) + (do ((npos '() (cons (mk-xpoint (car pos) (cadr pos)) npos)) + (pos (xlib:motion-events window :start start :stop stop) + (cdddr pos))) + ((null? pos) (nreverse npos)))) + +(define (x-warp-pointer dest-win point) + (xlib:warp-pointer dest-win (xpoint-x point) (xpoint-y point))) + +(define (x-set-input-focus display focus revert-to time) + (apply (function xlib:set-input-focus) + `(,display ,focus ,revert-to ,@(if time `(,time) '())))) + +(define (x-input-focus display) + (multiple-value-bind (focus revert-to) (xlib:input-focus display) + (make-h-tuple focus revert-to))) + +(define (x-grab-pointer window event-mask attrs time) + (apply (function xlib:grab-pointer) + `(,window ,event-mask + ,@(attrs->keywords attrs) + ,@(if time `(:time ,time) '())))) + +(define (x-ungrab-pointer display time) + (if time + (xlib:ungrab-pointer display :time time) + (xlib:ungrab-pointer display))) + +(define (x-change-active-pointer-grab display event-mask attrs time) + (apply (function xlib:change-active-pointer-grab) + `(,display ,event-mask + ,@(attrs->keywords attrs) + ,@(if time `(,time) '())))) + +(define (x-grab-button window button event-mask state-mask attrs) + (apply (function xlib:grab-button) + `(,window ,button ,event-mask :modifiers ,state-mask + ,@(attrs->keywords attrs)))) + +(define (x-ungrab-button window button modifiers) + (xlib:ungrab-button window button :modifiers modifiers)) + +(define (x-grab-keyboard window attrs time) + (apply (function xlib:grab-keyboard) + `(,window ,@(attrs->keywords attrs) + ,@(if time `(:time ,time) '())))) + +(define (x-ungrab-keyboard display time) + (if time + (xlib:ungrab-keyboard display :time time) + (xlib:ungrab-keyboard display))) + +(define (x-grab-key window key state-mask attrs) + (apply (function xlib:grab-key) + `(,window ,key :modifiers ,state-mask ,@(attrs->keywords attrs)))) + +(define (x-ungrab-key window key modifiers) + (xlib:ungrab-button window key :modifiers modifiers)) + +(define (x-set-pointer-acceleration display val) + (xlib:change-pointer-control display :acceleration val)) + +(define (x-set-pointer-threshold display val) + (xlib:change-pointer-control display :threshold val)) + +(define (x-pointer-acceleration display) + (lisp:coerce (nth-value 0 (xlib:pointer-control display)) + 'lisp:single-float)) + +(define (x-pointer-threshold display) + (lisp:coerce (nth-value 1 (xlib:pointer-control display)) + 'lisp:single-float)) + +(define-attribute-setter pointer mapping) + +(define (x-set-keyboard-key-click-percent display v) + (xlib:change-keyboard-control display :key-click-percent v)) + +(define (x-set-keyboard-bell-percent display v) + (xlib:change-keyboard-control display :bell-percent v)) + +(define (x-set-keyboard-bell-pitch display v) + (xlib:change-keyboard-control display :bell-pitch v)) + +(define (x-set-keyboard-bell-duration display v) + (xlib:change-keyboard-control display :bell-duration v)) + + +;;; Yes, leds are really counted from 1 rather than 0. + +(define (x-set-keyboard-led display v) + (declare (type integer v)) + (do ((led 1 (1+ led)) + (vv v (lisp:ash vv -1))) + ((> led 32)) + (declare (type fixnum led) (type integer vv)) + (xlib:change-keyboard-control display + :led led + :led-mode (if (lisp:logand vv 1) :on :off)))) + +(define (x-set-keyboard-auto-repeat-mode display v) + (do ((key 0 (1+ key))) + ((>= key (lisp:length v))) + (declare (type fixnum key)) + (xlib:change-keyboard-control display + :key key + :auto-repeat-mode (if (eqv? (the fixnum (lisp:aref v key)) 1) :on :off) + ))) + +(define (x-keyboard-key-click-percent display) + (nth-value 0 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-percent display) + (nth-value 1 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-pitch display) + (nth-value 2 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-duration display) + (nth-value 3 (xlib:keyboard-control display))) + +(define (x-keyboard-led display) + (nth-value 4 (xlib:keyboard-control display))) + +(define (x-keyboard-auto-repeat-mode display) + (nth-value 6 (xlib:keyboard-control display))) + +(define (x-modifier-mapping display) + (lisp:multiple-value-list (xlib:modifier-mapping display))) + +(define (x-set-modifier-mapping display l) + (let ((l1 (cddddr l))) + (xlib:set-modifier-mapping display + :shift (car l) + :lock (cadr l) + :control (caddr l) + :mod1 (cadddr l) + :mod2 (car l1) + :mod3 (cadr l1) + :mod4 (caddr l1) + :mod5 (cadddr l1)))) + +(define (x-keysym-character display keysym state) + (let ((res (xlib:keysym->character display keysym state))) + (if (char? res) (char->integer res) '()))) + +(define (x-keycode-character display keycode state) + (let ((res (xlib:keycode->character display keycode state))) + (if (char? res) (char->integer res) '()))) + +(define-attribute-setter close-down mode) + +(define-attribute-setter access control) + +(define (x-screen-saver display) + (lisp:multiple-value-list (xlib:screen-saver display))) + +(define (x-set-screen-saver display ss) + (xlib:set-screen-saver display (car ss) (cadr ss) (caddr ss) (cadddr ss))) + +(define (slots->keywords slots) + (if (null slots) '() + `(,@(slot->keyword (car slots)) ,@(slots->keywords (cdr slots))))) + +(define (slot->keyword slot) + (let* ((tag (keyword-key slot)) + (val (keyword-val slot))) + (case tag + (:pos `(:x ,(xpoint-x val) :y ,(xpoint-y val))) + (:root-pos `(:root-x ,(xpoint-x val) :root-y ,(xpoint-y val))) + (:size `(:width ,(xsize-w val) :height ,(xsize-h val))) + (:rect `(:x ,(xrect-x val) :y ,(xrect-y val) + :width ,(xrect-w val) :height ,(xrect-h val))) + (:graph-fun `(:major ,(car val) :minor ,(cdr val))) + (:visibility `(:state ,val)) + (:property-state `(:state ,val)) + (:message `(:data ,(car val) :type ,(cadr val) :format ,(caddr val))) + (else `(,tag ,val))))) + +(define (keywords->slots type keywords event) + (let* ((slots (keywords->slots1 type keywords)) + (has-root-xy (memq type '(:key-press :key-release :button-press + :button-release :motion-notify + :enter-notify :leave-notify))) + (has-xy (or has-root-xy + (memq type '(:gravity-notify :reparent-notify)))) + (has-graph-fun (memq type '(:graphics-exposure :no-exposure))) + (has-rect (memq type '(:exposure :graphics-exposure + :configure-notify + :create-notify :configure-request))) + (has-size (memq type '(:resize-request))) + (has-message (memq type '(:client-message)))) + (when has-xy + (push (make-keyword :pos (x-event-pos event)) slots)) + (when has-root-xy + (push (make-keyword :root-pos (x-event-root-pos event)) slots)) + (when has-graph-fun + (push (make-keyword :graph-fun (x-event-graph-fun event)) slots)) + (when has-rect + (push (make-keyword :rect (x-event-rect event)) slots)) + (when has-size + (push (make-keyword :size (x-event-size event)) slots)) + (when has-message + (push (make-keyword :message (x-event-message event)) slots)) + slots)) + +(define (keywords->slots1 type keywords) + (if (null? keywords) + '() + (if (memq (car keywords) + '(:x :y :width :height :root-x :root-y + :major :minor :type :data :format)) + (keywords->slots1 type (cddr keywords)) + (cons (keyword->slot type (car keywords) (cadr keywords)) + (keywords->slots1 type (cddr keywords)))))) + +(define (keyword->slot type slot val) + (if (eq? slot :state) + (case type + (:property-state (make-keyword :property-state val)) + (:visibility (make-keyword :visibility val)) + (else (make-keyword :state val))) + (make-keyword slot val))) + +(define (attrs->keywords attrs) + (if (null attrs) + '() + (nconc (attr->keyword (car attrs)) + (attrs->keywords (cdr attrs))))) + +(define (attr->keyword attr) + (let* ((tag (keyword-key attr)) + (val (keyword-val attr))) + (case tag + (:clip-origin `(:clip-x ,(xpoint-x val) :clip-y ,(xpoint-y val))) + (:dashes `(,tag ,(haskell-list->list/identity val))) + (:tile-origin `(:ts-x ,(xpoint-x val) :ts-y ,(xpoint-y val))) + (:size `(:width ,(xsize-w val) :height ,(xsize-h val))) + (:name `(:name ,(haskell-string->string val))) + (:hot-spot `(:x-hot ,(xpoint-x val) :y-hot ,(xpoint-y val))) + (else `(,tag ,val))))) + +(define (x-mutable-array-create inits) + (list->vector inits)) + +(define (x-mutable-array-lookup a i) + (vector-ref a i)) + +(define (x-mutable-array-update a i x) + (setf (vector-ref a i) x)) + +(define (x-mutable-array-length a) + (vector-length a)) + +(define (get-time-zone) + (nth-value 8 (lisp:get-decoded-time))) + +(define (decode-time time zone) + (multiple-value-bind (sec min hour date mon year week ds-p) + (if zone + (lisp:decode-universal-time time zone) + (lisp:decode-universal-time time)) + (make-h-tuple + (list->haskell-list/identity (list sec min hour date mon year week)) + ds-p))) + +(define (encode-time time zone) + (apply (function lisp:encode-universal-time) + (if (null? zone) time (append time (list zone))))) + +(define (get-run-time) + (/ (lisp:coerce (lisp:get-internal-run-time) 'lisp:single-float) + (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float))) + +(define (get-elapsed-time) + (/ (lisp:coerce (lisp:get-internal-real-time) 'lisp:single-float) + (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float))) + +(define (prim.thenio---1 x fn) + (lambda (state) + (declare (ignore state)) + (let ((res (funcall x (box 'state)))) + (format '#t "~A~%" res) + (funcall fn res (box 'state))))) + +(define-attribute-setter wm name) +(define-attribute-setter wm icon-name) diff --git a/progs/lib/X11/xlibprims.hi b/progs/lib/X11/xlibprims.hi new file mode 100644 index 0000000..02d4163 --- /dev/null +++ b/progs/lib/X11/xlibprims.hi @@ -0,0 +1,1465 @@ +-- 4/13/93 add xTestEventMask, xTestStateMask +-- 4/14/93 add xMArrayLength, +-- xGetEventN +-- 4/15/93 change xKeycodeCharacter +-- add xKeysymCharacter +-- add xHandleError +-- add xError +-- 4/27/93 Change Bool to XSwitch in XWinAttribute, XGCAttribute + +interface XLibPrims where + +import XLibTypes( + XDisplay, XScreen, XWindow, XGcontext, XPixmap, + XColormap, XCursor, XFont, XImage, XMaybe, XError, + XBitmap, XKeysymTable, XBitVec, + XPixarray, XByteVec, XAtom, XProperty, + XPixel, XDrawable, XTime, XSwitch, + XWindowPlace, XEventMode, XEventKind, + XWindowVisibility, XWindowStackMode, + XPropertyState, XMapReqType, XGraphFun, + XEvent, XEventType, XEventSlot, XEventMask, + XEventMaskKey, XStateMask, XStateMaskKey, + XWinAttribute,XGCAttribute, XImAttribute, + XGrabAttribute, XArcMode, XCapStyle, + XClipMask, XFillRule, XFillStyle, + XFunction, XJoinStyle, XLineStyle, + XSubwindowMode, XPoint, XSize, XRect, + XArc, XBitmapFormat, XByteOrder, + XPixmapFormat, XVisualInfo, XVisualClass, + XFillContent, XBackingStore, XGravity, + XWindowClass, XMapState, XImageData, + XImageFormat, XImageType, XDrawDirection, + XColor, XInputFocus, XGrabStatus, + XKeysym, XCloseDownMode, XScreenSaver) + +xHandleError :: (XError -> IO a) -> IO a -> IO a +xError :: String -> IO a + +xEventType :: XEvent -> XEventType +xEventWindow :: XEvent -> XWindow +xEventEventWindow :: XEvent -> XWindow +xEventCode :: XEvent -> Int +xEventPos :: XEvent -> XPoint +xEventState :: XEvent -> XStateMask +xEventTime :: XEvent -> XTime +xEventRoot :: XEvent -> XWindow +xEventRootPos :: XEvent -> XPoint +xEventChild :: XEvent -> (XMaybe XWindow) +xEventSameScreenP :: XEvent -> Bool +xEventHintP :: XEvent -> Bool +xEventMode :: XEvent -> XEventMode +xEventKind :: XEvent -> XEventKind +xEventFocusP :: XEvent -> Bool +xEventKeymap :: XEvent -> XBitVec +xEventRequest :: XEvent -> XMapReqType +xEventStart :: XEvent -> Int +xEventCount :: XEvent -> Int +xEventRect :: XEvent -> XRect +xEventDrawable :: XEvent -> XDrawable +xEventXGraphFun :: XEvent -> XGraphFun +xEventPlace :: XEvent -> XWindowPlace +xEventBorderWidth :: XEvent -> Int +xEventAboveSibling :: XEvent -> (XMaybe XWindow) +xEventOverrideRedirectP :: XEvent -> Bool +xEventParent :: XEvent -> XWindow +xEventConfigureP :: XEvent -> Bool +xEventVisibility :: XEvent -> XWindowVisibility +xEventNewP :: XEvent -> Bool +xEventInstalledP :: XEvent -> Bool +xEventStackMode :: XEvent -> XWindowStackMode +xEventValueMask :: XEvent -> Int +xEventSize :: XEvent -> XSize +xEventMessage :: XEvent -> XProperty +xEventPropertyState :: XEvent -> XPropertyState +xEventAtom :: XEvent -> XAtom +xEventSelection :: XEvent -> XAtom +xEventTarget :: XEvent -> XAtom +xEventProperty :: XEvent -> (XMaybe XAtom) +xEventRequestor :: XEvent -> XWindow + +xSetEventMaskKey :: XEventMask -> XEventMaskKey -> XEventMask +xClearEventMaskKey :: XEventMask -> XEventMaskKey -> XEventMask +xTestEventMaskKey :: XEventMask -> XEventMaskKey -> Bool + +xSetStateMaskKey :: XStateMask -> XStateMaskKey -> XStateMask +xClearStateMaskKey :: XStateMask -> XStateMaskKey -> XStateMask +xTestStateMaskKey :: XStateMask -> XStateMaskKey -> Bool + + +-- DISPLAYS + +-- open + +xOpenDisplay :: String -- host:display + -> IO XDisplay + +-- display attributes + +xDisplayAuthorizationData :: XDisplay -> String +xDisplayAuthorizationName :: XDisplay -> String +xDisplayBitmapFormat :: XDisplay -> XBitmapFormat +xDisplayByteOrder :: XDisplay -> XByteOrder +xDisplayDisplay :: XDisplay -> Int +xSetDisplayErrorHandler :: XDisplay -> (XError -> IO ()) -> IO () +xDisplayImageLsbFirstP :: XDisplay -> Bool +xDisplayMaxKeycode :: XDisplay -> Int +xDisplayMaxRequestLength :: XDisplay -> Int +xDisplayMinKeycode :: XDisplay -> Int +xDisplayMotionBufferSize :: XDisplay -> Int +xDisplayPixmapFormats :: XDisplay -> [XPixmapFormat] +xDisplayProtocolMajorVersion :: XDisplay -> Int +xDisplayProtocolMinorVersion :: XDisplay -> Int +xDisplayResourceIdBase :: XDisplay -> Int +xDisplayResourceIdMask :: XDisplay -> Int +xDisplayRoots :: XDisplay -> [XScreen] +xDisplayVendorName :: XDisplay -> String +xDisplayReleaseNumber :: XDisplay -> Int + +-- output buffer + +xDisplayAfterFunction :: XDisplay -> XMaybe (IO ()) +xSetDisplayAfterFunction :: XDisplay -> XMaybe (IO ()) -> IO () +xDisplayForceOutput :: XDisplay -> IO () +xDisplayFinishOutput :: XDisplay -> IO () + +-- close + +xCloseDisplay :: XDisplay -> IO () + +-- SCREENS + +xScreenBackingStores :: XScreen -> XBackingStore +xScreenBlackPixel :: XScreen -> XPixel +xScreenDefaultColormap :: XScreen -> XColormap +xScreenDepths :: XScreen -> [(Int, [XVisualInfo])] +xScreenEventMaskAtOpen :: XScreen -> XEventMask +xScreenSize :: XScreen -> XSize +xScreenMMSize :: XScreen -> XSize +xScreenMaxInstalledMaps :: XScreen -> Int +xScreenMinInstalledMaps :: XScreen -> Int +xScreenRoot :: XScreen -> XWindow +xScreenRootDepth :: XScreen -> Int +xScreenRootVisual :: XScreen -> Int +xScreenSaveUndersP :: XScreen -> Bool +xScreenWhitePixel :: XScreen -> XPixel + +-- WINDOWS AND PIXMAPS + +-- drawables + +xDrawableDisplay :: XDrawable -> XDisplay +xDrawableEqual :: XDrawable -> XDrawable -> Bool +xDrawableId :: XDrawable -> Int + +-- creating windows + +xCreateWindow :: XWindow -- parent + -> XRect -- (x,y,width,height) + -> [XWinAttribute] -- optional arguments + -> IO XWindow + +-- window attributes + +xWindowBorderWidth :: XWindow -> IO Int +xSetWindowBorderWidth :: XWindow -> Int -> IO () + +xDrawableDepth :: XDrawable -> Int + +xDrawableSize :: XDrawable -> IO XSize +xDrawableResize :: XDrawable -> XSize -> IO () + +xWindowPos :: XWindow -> IO XPoint +xWindowMove :: XWindow -> XPoint -> IO () + +xWindowAllEventMasks :: XWindow -> IO XEventMask +xSetWindowBackground :: XWindow -> XFillContent -> IO () + +xWindowBackingPixel :: XWindow -> IO XPixel +xSetWindowBackingPixel :: XWindow -> XPixel -> IO () + +xWindowBackingPlanes :: XWindow -> IO XPixel +xSetWindowBackingPlanes :: XWindow -> XPixel -> IO () + +xWindowBackingStore :: XWindow -> IO XBackingStore +xSetWindowBackingStore :: XWindow -> XBackingStore -> IO () + +xWindowBitGravity :: XWindow -> IO XGravity +xSetWindowBitGravity :: XWindow -> XGravity -> IO () + +xSetWindowBorder :: XWindow -> XFillContent -> IO () + +xWindowClass :: XWindow -> XWindowClass + +xWindowColorMap :: XWindow -> IO (XMaybe XColormap) +xSetWindowColorMap :: XWindow -> XColormap -> IO () +xWindowColormapInstalledP :: XWindow -> IO Bool + +xSetWindowCursor :: XWindow -> (XMaybe XCursor) -> IO () + +xWindowDisplay :: XWindow -> XDisplay + +xWindowDoNotPropagateMask :: XWindow -> IO XEventMask +xSetWindowDoNotPropagateMask :: XWindow -> XEventMask -> IO () + +xWindowEqual :: XWindow -> XWindow -> Bool + +xWindowEventMask :: XWindow -> IO XEventMask +xSetWindowEventMask :: XWindow -> XEventMask -> IO () + +xWindowGravity :: XWindow -> IO XGravity +xSetWindowGravity :: XWindow -> XGravity -> IO () + +xWindowId :: XWindow -> Int + +xWindowMapState :: XWindow -> IO XMapState + +xWindowOverrideRedirect :: XWindow -> IO XSwitch +xSetWindowOverrideRedirect :: XWindow -> XSwitch -> IO () + +xSetWindowPriority :: XWindow -> XWindowStackMode -> IO () + +xWindowSaveUnder :: XWindow -> IO XSwitch +xSetWindowSaveUnder :: XWindow -> XSwitch -> IO () + +xWindowVisual :: XWindow -> Int + +-- stacking order + +xCirculateWindowDown :: XWindow -> IO () +xCirculateWindowUp :: XWindow -> IO () + +-- window hierarchy + +xDrawableRoot :: XDrawable -> IO XWindow +xQueryTree :: XWindow -> IO ([XWindow], -- children + XMaybe XWindow,-- parent + XWindow) -- root + +xReparentWindow :: XWindow -- window + -> XWindow -- parent + -> XPoint -- (x,y) + -> IO () + +xTranslateCoordinates :: XWindow -- source + -> XPoint -- (source-x,source-y) + -> XWindow -- destination + -> IO (XMaybe XPoint) -- (dest-x,dest-y) + +-- mapping windows + +xMapWindow :: XWindow -> IO () +xMapSubwindows :: XWindow -> IO () +xUnmapWindow :: XWindow -> IO () +xUnmapSubwindows :: XWindow -> IO () + +-- destroying windows + +xDestroyWindow :: XWindow -> IO () +xDestroySubwindows :: XWindow -> IO () + +-- pixmaps + +xCreatePixmap :: XSize -- (width,height) + -> Int -- depth + -> XDrawable -- drawable + -> IO XPixmap + +xFreePixmap :: XPixmap -> IO () + +xPixmapDisplay :: XPixmap -> XDisplay +xPixmapEqual :: XPixmap -> XPixmap -> Bool + +-- GRAPHICS CONTEXTS + +xCreateGcontext :: XDrawable -- drawable + -> [XGCAttribute] -- optional arguments + -> IO XGcontext + +xUpdateGcontext :: XGcontext -- old gcontext + -> [XGCAttribute] -- changes + -> IO () -- new gcontext + +xFreeGcontext :: XGcontext -> IO () + +xGcontextDisplay :: XGcontext -> XDisplay +xGcontextEqual :: XGcontext -> XGcontext -> Bool + +xGcontextId :: XGcontext -> Int + +xQueryBestStipple :: XSize -> XDrawable -> XSize +xQueryBestTile :: XSize -> XDrawable -> XSize + +xCopyGcontext :: XGcontext -- source + -> XGcontext -- destination + -> IO () + +-- GRAPHICS OPERATIONS + +xClearArea :: XWindow -- window + -> XRect -- (x,y,width,height) + -> Bool -- exposure-p + -> IO () + +xCopyArea :: XDrawable -- source + -> XGcontext -- gcontext + -> XRect -- (src-x,src-y,w,h) + -> XDrawable -- destination + -> XPoint -- (dest-x,dest-y) + -> IO () + +xCopyPlane :: XDrawable -- source + -> XGcontext -- gcontext + -> XPixel -- plane + -> XRect -- (src-x,src-y,w,h) + -> XDrawable -- destination + -> XPoint -- (dest-x,dest-y) + -> IO () + +xDrawPoint :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> IO () + +xDrawPoints :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XPoint] -- points + -> IO () + +xDrawLine :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x1,y1) + -> XPoint -- (x2,y2) + -> IO () + +xDrawLines :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XPoint] -- points + -> Bool -- fill-p + -> IO () + +xDrawSegments :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [(XPoint,XPoint)] -- segments + -> IO () + +xDrawRectangle :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XRect -- (x,y,width,height) + -> Bool -- fill-p + -> IO () + +xDrawRectangles :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XRect] -- rectangles + -> Bool -- fill-p + -> IO () + +xDrawArc :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XArc -- (x,y,w,h,a1,a2) + -> Bool -- fill-p + -> IO () + +xDrawArcs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XArc] -- arcs + -> Bool -- fill-p + -> IO () + +xDrawGlyph :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> Char -- element + -> IO (XMaybe Int) -- width + +xDrawGlyphs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> String -- sequence + -> IO (XMaybe Int) -- width + +xDrawImageGlyph :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> Char -- element + -> IO (XMaybe Int) -- width + +xDrawImageGlyphs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> String -- sequence + -> IO (XMaybe Int) -- width + +-- IMAGES + +xImageBlueMask :: XImage -> XMaybe XPixel +xImageDepth :: XImage -> Int +xImageGreenMask :: XImage -> XMaybe XPixel +xImageSize :: XImage -> XSize +xImageName :: XImage -> String +xSetImageName :: XImage -> String -> IO () +xImageRedMask :: XImage -> XMaybe XPixel +xImageHotSpot :: XImage -> XMaybe XPoint +xSetImageHotSpot :: XImage -> XPoint -> IO () + +-- XY-format images + +xImageXYBitmaps :: XImage -> IO [XBitmap] +xSetImageXYBitmaps :: XImage -> [XBitmap] -> IO () + +-- Z-format images + +xImageZBitsPerPixel :: XImage -> IO Int +xsetImageZBitsPerPixel :: XImage -> Int -> IO () +xImageZPixarray :: XImage -> IO XPixarray +xSetImageZPixarray :: XImage -> XPixarray -> IO () + +-- image functions + +xCreateImage :: [XImAttribute] -> IO XImage +xCopyImage :: XImage -- image + -> XRect -- (x,y,width,height) + -> XImageType -- result-type + -> XImage -- new-image + +xGetImage :: XDrawable -- drawable + -> XRect -- (x,y,width,height) + -> XPixel -- plane-mask + -> XImageFormat -- format + -> XImageType -- result-type + -> IO XImage -- image + +xPutImage :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XImage -- ximage + -> XPoint -- (src-x,src-y) + -> XRect -- (x,y,width,height) + -> IO () + +-- image files + +xReadBitmapFile :: String -- pathname + -> IO XImage + +xWriteBitmapFile :: String -- pathname + -> XImage -> IO () + +-- direct image transfer + +xGetRawImage :: XDrawable -- drawable + -> XRect -- (x,y,width,height) + -> XPixel -- plane-mask + -> XImageFormat -- format + -> IO XImageData -- data + +xPutRawImage :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XImageData -- data + -> Int -- depth + -> XRect -- (x,y,width,height) + -> Int -- left-pad + -> XImageFormat -- format + -> IO () + +-- FONTS + +-- opening fonts + +xOpenFont :: XDisplay -> String -> IO XFont +xCloseFont :: XFont -> IO () +xDiscardFontInfo :: XFont -> IO () + +-- listing fonts + +xFontPath :: XDisplay -> IO [String] +xListFontNames :: XDisplay -> String -- pattern + -> IO [String] +xListFonts :: XDisplay -> String -- pattern + -> IO [XFont] + +-- font attriburtes + +xFontAllCharExistsP :: XFont -> Bool +xFontAscent :: XFont -> Int +xFontDefaultChar :: XFont -> Int +xFontDescent :: XFont -> Int +xFontDirection :: XFont -> XDrawDirection +xFontDisplay :: XFont -> XDisplay +xFontEqual :: XFont -> XFont -> Int +xFontId :: XFont -> Int + +xFontMaxByte1 :: XFont -> Int +xFontMaxByte2 :: XFont -> Int +xFontMaxChar :: XFont -> Int +xFontMinByte1 :: XFont -> Int +xFontMinByte2 :: XFont -> Int +xFontMinChar :: XFont -> Int + +xFontName :: XFont -> String + +xFontMaxCharAscent :: XFont -> Int +xFontMaxCharAttributes :: XFont -> Int +xFontMaxCharDescent :: XFont -> Int +xFontMaxCharLeftBearing :: XFont -> Int +xFontMaxCharRightBearing :: XFont -> Int +xFontMaxCharWidth :: XFont -> Int +xFontMinCharAscent :: XFont -> Int +xFontMinCharAttributes :: XFont -> Int +xFontMinCharDescent :: XFont -> Int +xFontMinCharLeftBearing :: XFont -> Int +xFontMinCharRightBearing :: XFont -> Int +xFontMinCharWidth :: XFont -> Int + +-- char attributes + +xCharAscent :: XFont -> Int -> XMaybe Int +xCharAttributes :: XFont -> Int -> XMaybe Int +xCharDescent :: XFont -> Int -> XMaybe Int +xCharLeftBearing :: XFont -> Int -> XMaybe Int +xCharRightBearing :: XFont -> Int -> XMaybe Int +xCharWidth :: XFont -> Int -> XMaybe Int + +-- querying text size + +xTextWidth :: XFont -- font + -> String -- sequence + -> Int -- width + +-- COLORS + +-- creating colormaps + +xCreateColormap :: XVisualInfo -- visual + -> XWindow -- window + -> Bool -- alloc-p + -> IO XColormap + +xCopyColormapAndFree :: XColormap -> IO XColormap +xFreeColormap :: XColormap -> IO () + +-- installing colormaps + +xInstallColormap :: XColormap -> IO () +xInstalledColormaps :: XWindow -> IO [XColormap] +xUnInstallColormap :: XColormap -> IO () + +-- allocating colors + +xAllocColor :: XColormap -> XColor + -> IO (XPixel, -- pixel + XColor, -- screen-color + XColor) -- exact-color + +xAllocColorCells :: XColormap -- pixel + -> Int -- colors + -> Int -- planes + -> Bool -- contiguous + -> IO ([XPixel], -- pixels + [XPixel]) -- mask + +xAllocColorPlanes :: XColormap -- colormap + -> Int -- colors + -> Int -- reds + -> Int -- greens + -> Int -- blues + -> Bool -- contiguous-p + -> IO ([XPixel], -- pixel + XPixel, -- red-mask + XPixel, -- green-mask + XPixel) -- blue-mask + +xFreeColors :: XColormap -> [XPixel] -- pixels + -> XPixel -- plane-mask + -> IO () + +-- finding colors + +xLookupColor :: XColormap -> String -- name + -> IO (XColor, -- screen-color + XColor) -- exact-color + +xQueryColors :: XColormap -> [XPixel] -- pixels + -> IO [XColor] + +-- changing colors + +xStoreColor :: XColormap -> XPixel -- pixel + -> XColor -- color + -> IO () + +xStoreColors :: XColormap -- colormap + -> [(XPixel, XColor)] -- pixel-colors + -> IO () + +-- colormap attributes + +xColormapDisplay :: XColormap -> XDisplay +xColormapEqual :: XColormap -> XColormap -> Bool + +-- CURSORS + +xCreateCursor :: XPixmap -- source + -> (XMaybe XPixmap) -- mask + -> XPoint -- (x,y) + -> XColor -- foreground + -> XColor -- background + -> IO XCursor + +xCreateGlyphCursor :: (XFont, char) -- (src-font,src-char) + -> (XMaybe (XFont, Char)) -- (mask-font,mask-char) + -> XColor -- foreground + -> XColor -- background + -> IO XCursor + +xFreeCursor :: XCursor -> IO () + +xQueryBestCursor :: XSize -- (width,height) + -> XDisplay -> IO XSize + +xRecolorCursor :: XCursor -> XColor -- foreground + -> XColor -- background + -> IO () + +xCursorDisplay :: XCursor -> XDisplay +xCursorEqual :: XCursor -> XCursor -> Bool + +-- ATOMS, PROPERTIES, AND SELECTIONS + +-- atoms + +xAtomName :: XDisplay -> Int -- atom-id + -> XAtom + +xFindAtom :: XDisplay -> XAtom -- atom-name + -> IO (XMaybe Int) + +xInternAtom :: XDisplay -> XAtom -- atom-name + -> IO (XMaybe Int) + +-- properties + +xChangeProperty :: XWindow -- window + -> XAtom -- property + -> XProperty -- (data,type,format) + -> IO () + +xDeleteProperty :: XWindow -> XAtom -> IO () +xGetProperty :: XWindow -- window + -> XAtom -- property + -> IO XProperty -- (data,type,format) + +xListProperties :: XWindow -> IO [XAtom] +xRotateProperties :: XWindow -- window + -> [XAtom] -- properties + -> Int -- delta + -> IO () + +-- selections + +xConvertSelection :: XAtom -- selection + -> XAtom -- type + -> XWindow -- requester + -> XAtom -- property + -> (XMaybe XTime) -- time + -> IO () + +xSelectionOwner :: XDisplay -- display + -> XAtom -- selection + -> IO (XMaybe XWindow) + +xSetSelectionOwner :: XDisplay -- display + -> XAtom -- selection + -> (XMaybe XTime) -- time + -> XWindow -- owner + -> IO () + +-- EVENT + +-- Wait for the next event + +xGetEvent :: XDisplay -> IO XEvent + +-- managing the event queue + +xQueueEvent :: XDisplay -> XEvent -> Bool -- append-p + -> IO () + +xEventListen :: XDisplay -> IO Int -- # of events in queue + +-- sending events + +xSendEvent :: XWindow -- window + -> XEvent -- event key and slots + -> XEventMask -- event-mask + -> IO () + +-- pointer position + +xGlobalPointerPosition :: XDisplay -> IO XPoint +xPointerPosition :: XWindow -> IO (XMaybe XPoint) +xMotionEvents :: XWindow -> XTime -> XTime -> IO [XPoint] +xWarpPointer :: XWindow -> XPoint -> IO () + +-- keyboard input focus + +xSetInputFocus :: XDisplay -- display + -> XInputFocus -- focus + -> XInputFocus -- revert-to + -> (XMaybe XTime) -- time + -> IO () + +xInputFucus :: XDisplay -> IO (XInputFocus, -- focus + XInputFocus) -- revert-to + +-- grabbing the pointer + +xGrabPointer :: XWindow -- window + -> XEventMask -- event-mask + -> [XGrabAttribute] -- optional attributes + -> XMaybe XTime -- time + -> IO XGrabStatus + +xUngrabPointer :: XDisplay -> XMaybe XTime -> IO () + +xChangeActivePointerGrab :: XDisplay -> XEventMask -- event-mask + -> [XGrabAttribute] -- cursor + -> XMaybe XTime -> IO () + +-- grabbing a button + +xGrabButton :: XWindow -- window + -> Int -- button + -> XEventMask -- event-mask + -> XStateMask -- modifiers + -> [XGrabAttribute] -- optional attributes + -> IO () + +xUngrabButton :: XWindow -> Int -- button + -> XStateMask -- modifiers + -> IO () + +-- grabbing the keyboard + +xGrabKeyboard :: XWindow -- window + -> [XGrabAttribute] -- optional attributes + -> XMaybe XTime -- time + -> IO XGrabStatus + +xUngrabkeyboard :: XDisplay -> XMaybe XTime -> IO () + +-- grabbing a key + +xGrabKey :: XWindow -- window + -> Int -- key + -> XStateMask -- modifiers + -> [XGrabAttribute] -- optional attributes + -> IO () + +xUngrabKey :: XWindow -> Int -> XStateMask -- modifiers + -> IO () + +-- CONTROL FUNCTIONS + +-- grabbing the server + +xGrabServer :: XDisplay -> IO () +xUngrabServer :: XDisplay -> IO () + +-- pointer control + +xSetPointerAcceleration :: XDisplay -> Float -> IO () +xSetPointerThreshold :: XDisplay -> Float -> IO () +xPointerAcceleration :: XDisplay -> IO Float +xPointerThreshold :: XDisplay -> IO Float +xSetPointerMapping :: XDisplay -> [Int] -> IO () +xPointerMapping :: XDisplay -> IO [Int] + +-- keyboard control + +xBell :: XDisplay -> Int -> IO () + +xSetKeyboardKeyClickPercent :: XDisplay -> Int -> IO () +xSetKeyboardBellPercent :: XDisplay -> Int -> IO () +xSetKeyboardBellPitch :: XDisplay -> Int -> IO () +xSetKeyboardBellDuration :: XDisplay -> Int -> IO () +xSetKeyboardLed :: XDisplay -> Integer -> IO () +xSetKeyboardAutoRepeatMode :: XDisplay -> XBitVec -> IO () + +xKeyboardKeyClickPercent :: XDisplay -> IO Int +xKeyboardBellPercent :: XDisplay -> IO Int +xKeyboardBellPitch :: XDisplay -> IO Int +xKeyboardBellDuration :: XDisplay -> IO Int + +xKeyboardLed :: XDisplay -> IO Integer +xKeyboardAutoRepeatMode :: XDisplay -> IO XBitVec + +xModifierMapping :: XDisplay -> IO [[Int]] +xSetModifierMapping :: XDisplay -> [[Int]] -> IO (XMaybe ()) +xQueryKeymap :: XDisplay -> IO XBitVec + +-- keyboard mapping + +xChangeKeyboardMapping :: XDisplay -- display + -> XKeysymTable -- keysyms + -> IO () + +xKeyboardMapping :: XDisplay -- display + -> IO XKeysymTable -- mappings + +xKeycodeKeysym :: XDisplay -- display + -> Int -- keycode + -> Int -- keysym-index + -> IO XKeysym + +xKeysymCharacter :: XDisplay -- display + -> XKeysym -- keysym + -> XStateMask -- state + -> IO (XMaybe Char) + +xKeycodeCharacter :: XDisplay -- display + -> Int -- keycode + -> XStateMask -- state + -> IO (XMaybe Char) + +-- client termination + +xAddToSaveSet :: XWindow -> IO () +xCloseDownMode :: XDisplay -> IO XCloseDownMode +xSetCloseDownMode :: XDisplay -> XCloseDownMode -> IO () +xKillClient :: XDisplay -> Int -> IO () +xKillTemporaryClients :: XDisplay -> IO () +xRemoveFromSaveSet :: XWindow -> IO () + +-- managing host access + +xAccessControl :: XDisplay -> IO Bool +xSetAccessControl :: XDisplay -> Bool -> IO () +xAccessHosts :: XDisplay -> IO [String] +xAddAccessHost :: XDisplay -> String -> IO () +xRemoveAccessHost :: XDisplay -> String -> IO () + +-- screen saver + +xActivateScreenSaver :: XDisplay -> IO () +xResetScreenSaver :: XDisplay -> IO () + +xScreenSaver :: XDisplay -> IO XScreenSaver +xSetScreenSaver :: XDisplay -> XScreenSaver -> IO () + +{-# + + +xHandleError :: LispName("x-handle-error") +xError :: LispName("xlib::x-error") + +xEventType :: LispName("sel-event-type") + +xEventWindow :: LispName ("x-event-window") +xEventEventWindow :: LispName ("x-event-event-window") +xEventCode :: LispName ("x-event-code") +xEventPos :: LispName ("x-event-pos") +xEventState :: LispName ("x-event-state") +xEventTime :: LispName ("x-event-time") +xEventRoot :: LispName ("x-event-root") +xEventRootPos :: LispName ("x-event-root-pos") +xEventChild :: LispName ("x-event-child") +xEventSameScreenP :: LispName ("x-event-same-screen-p") +xEventHintP :: LispName ("x-event-hint-p") +xEventMode :: LispName ("x-event-mode") +xEventKind :: LispName ("x-event-kind") +xEventFocusP :: LispName ("x-event-focus-p") +xEventKeymap :: LispName ("x-event-keymap") +xEventRequest :: LispName ("x-event-request") +xEventStart :: LispName ("x-event-start") +xEventCount :: LispName ("x-event-count") +xEventRect :: LispName ("x-event-rect") +xEventDrawable :: LispName ("x-event-drawable") +xEventXGraphFun :: LispName ("x-event-graph-fun") +xEventPlace :: LispName ("x-event-place") +xEventBorderWidth :: LispName ("x-event-border-width") +xEventAboveSibling :: LispName ("x-event-above-sibling") +xEventOverrideRedirectP :: LispName ("x-event-override-redirect-p") +xEventParent :: LispName ("x-event-parent") +xEventConfigureP :: LispName ("x-event-configure-p") +xEventVisibility :: LispName ("x-event-state") +xEventNewP :: LispName ("x-event-new-p") +xEventInstalledP :: LispName ("x-event-installed-p") +xEventStackMode :: LispName ("x-event-stack-mode") +xEventValueMask :: LispName ("x-event-value-mask") +xEventSize :: LispName ("x-event-size") +xEventMessage :: LispName ("x-event-message") +xEventPropertyState :: LispName ("x-event-state") +xEventAtom :: LispName ("x-event-atom") +xEventSelection :: LispName ("x-event-selection") +xEventTarget :: LispName ("x-event-target") +xEventProperty :: LispName ("x-event-property") +xEventRequestor :: LispName ("x-event-requestor") + + +xSetEventMaskKey :: LispName ("x-set-event-mask-key") +xClearEventMaskKey :: LispName ("x-clear-event-mask-key") +xTestEventMaskKey :: LispName ("x-test-event-mask-key") + +xSetStateMaskKey :: LispName ("x-set-state-mask-key") +xClearStateMaskKey :: LispName ("x-clear-state-mask-key") +xTestStateMaskKey :: LispName ("x-test-state-mask-key") + +-- DISPLAYS + +-- open + +xOpenDisplay :: LispName("x-open-display") + +-- display attributes + +xDisplayAuthorizationData :: LispName("xlib:display-authorization-data") +xDisplayAuthorizationName :: LispName("xlib:display-authorization-name") +xDisplayBitmapFormat :: LispName("xlib:display-bitmap-format") +xDisplayByteOrder :: LispName("xlib:display-byte-order") +xDisplayDisplay :: LispName("xlib:display-display") +xSetDisplayErrorHandler :: LispName("x-set-display-error-handler") +xDisplayImageLsbFirstP :: LispName("xlib:display-image-lsb-first-p") +xDisplayMaxKeycode :: LispName("xlib:display-max-keycode") +xDisplayMaxRequestLength :: LispName("xlib:display-max-request-length") +xDisplayMinKeycode :: LispName("xlib:display-min-keycode") +xDisplayMotionBufferSize :: LispName("xlib:display-motion-buffer-size") +xDisplayPixmapFormats :: LispName("xlib:display-pixmap-formats") +xDisplayProtocolMajorVersion :: LispName("xlib:display-protocol-major-version") +xDisplayProtocolMinorVersion :: LispName("xlib:display-protocol-minor-version") +xDisplayResourceIdBase :: LispName("xlib:display-resource-id-base") +xDisplayResourceIdMask :: LispName("xlib:display-resource-id-mask") +xDisplayRoots :: LispName("xlib:display-roots") +xDisplayVendorName :: LispName("xlib:display-vendor-name") +xDisplayReleaseNumber :: LispName("xlib:display-release-number") + +-- output buffer + +xDisplayAfterFunction :: LispName("xlib:display-after-function") +xSetDisplayAfterFunction :: LispName("x-set-display-after-function") +xDisplayForceOutput :: LispName("xlib:display-force-output") +xDisplayFinishOutput :: LispName("xlib:display-finish-output") + +-- close + +xCloseDisplay :: LispName("xlib:close-display") + +-- SCREENS + +xScreenBackingStores :: LispName("xlib:screen-backing-stores") +xScreenBlackPixel :: LispName("xlib:screen-black-pixel") +xScreenDefaultColormap :: LispName("xlib:screen-default-colormap") +xScreenDepths :: LispName("x-screen-depths") +xScreenEventMaskAtOpen :: LispName("xlib:screen-event-mask-at-open") +xScreenSize :: LispName("x-screen-size") +xScreenMMSize :: LispName("x-screen-mmsize") +xScreenMaxInstalledMaps :: LispName("xlib:screen-max-installed-maps") +xScreenMinInstalledMaps :: LispName("xlib:screen-min-installed-maps") +xScreenRoot :: LispName("xlib:screen-root") +xScreenRootDepth :: LispName("xlib:screen-root-depth") +xScreenRootVisual :: LispName("xlib:screen-root-visual") +xScreenSaveUndersP :: LispName("xlib:screen-save-unders-p") +xScreenWhitePixel :: LispName("xlib:screen-white-pixel") + +-- WINDOWS AND PIXMAPS + +-- drawables + +xDrawableDisplay :: LispName("xlib:drawable-display") +xDrawableEqual :: LispName("xlib:drawable-equal") +xDrawableId :: LispName("xlib:drawable-id") + +-- creating windows + +xCreateWindow :: LispName("x-create-window") + +-- window attributes + +xWindowBorderWidth :: LispName("xlib:drawable-border-width") +xSetWindowBorderWidth :: LispName("x-set-drawable-border-width") + +xDrawableDepth :: LispName("xlib:drawable-depth") + +xDrawableSize :: LispName("x-drawable-size") +xDrawableResize :: LispName("x-drawable-resize") + +xWindowPos :: LispName("x-window-pos") +xWindowMove :: LispName("x-window-move") + +xWindowAllEventMasks :: LispName("xlib:window-all-event-masks") + +xSetWindowBackground :: LispName("x-set-window-background") + +xWindowBackingPixel :: LispName("xlib:window-backing-pixel") +xSetWindowBackingPixel :: LispName("x-set-window-backing-pixel") + +xWindowBackingPlanes :: LispName("xlib:window-backing-planes") +xSetWindowBackingPlanes :: LispName("x-set-window-backing-planes") + +xWindowBackingStore :: LispName("xlib:window-backing-store") +xSetWindowBackingStore :: LispName("x-set-window-backing-store") + +xWindowBitGravity :: LispName("xlib:window-bit-gravity") +xSetWindowBitGravity :: LispName("x-set-window-bit-gravity") + +xSetWindowBorder :: LispName("x-set-window-border") + +xWindowClass :: LispName("xlib:window-class") + +xWindowColorMap :: LispName("xlib:window-colormap") +xSetWindowColorMap :: LispName("x-set-window-colormap") +xWindowColormapInstalledP :: LispName("xlib:window-colormap-installed-p") + +xSetWindowCursor :: LispName("x-set-window-cursor") + +xWindowDisplay :: LispName("xlib:window-display") + +xWindowDoNotPropagateMask :: LispName("xlib:window-do-not-propagate-mask") +xSetWindowDoNotPropagateMask :: LispName("x-set-window-do-not-propagate-mask") + +xWindowEqual :: LispName("xlib:window-equal") + +xWindowEventMask :: LispName("xlib:window-event-mask") +xSetWindowEventMask :: LispName("x-set-window-event-mask") + +xWindowGravity :: LispName("xlib:window-gravity") +xSetWindowGravity :: LispName("x-set-window-gravity") + +xWindowId :: LispName("xlib:window-id") + +xWindowMapState :: LispName("xlib:window-map-state") + +xWindowOverrideRedirect :: LispName("xlib:window-override-redirect") +xSetWindowOverrideRedirect :: LispName("x-set-window-override-redirect") + +xSetWindowPriority :: LispName("x-set-window-priority") + +xWindowSaveUnder :: LispName("xlib:window-save-under") +xSetWindowSaveUnder :: LispName("x-set-window-save-under") +xWindowVisual :: LispName("xlib:window-visual") + +-- stacking order + +xCirculateWindowDown :: LispName("xlib:circulate-window-down") +xCirculateWindowUp :: LispName("xlib:circulate-window-up") + +-- window hierarchy + +xDrawableRoot :: LispName("xlib:drawable-root") +xQueryTree :: LispName("x-query-tree") + +xReparentWindow :: LispName("x-reparent-window") + +xTranslateCoordinates :: LispName("x-translate-coordinates") + +-- mapping windows + +xMapWindow :: LispName("xlib:map-window") +xMapSubwindows :: LispName("xlib:map-subwindows") +xUnmapWindow :: LispName("xlib:unmap-window") +xUnmapSubwindows :: LispName("xlib:unmap-subwindows") + +-- destroying windows + +xDestroyWindow :: LispName("xlib:destroy-window") +xDestroySubwindows :: LispName("xlib:destroy-subwindows") + +-- pixmaps + +xCreatePixmap :: LispName("x-create-pixmap") +xFreePixmap :: LispName("xlib:free-pixmap") +xPixmapDisplay :: LispName("xlib:pixmap-display") +xPixmapEqual :: LispName("xlib:pixmap-equal") + +-- GRAPHICS CONTEXTS + +xCreateGcontext :: LispName("x-create-gcontext") +xUpdateGcontext :: LispName("x-update-gcontext") +xFreeGcontext :: LispName("xlib:free-gcontext") + +xGcontextDisplay :: LispName("xlib:gcontext-display") +xGcontextEqual :: LispName("xlib:gcontext-equal") + +xGcontextId :: LispName("xlib:gcontext-id") + +xQueryBestStipple :: LispName("x-query-best-stipple") +xQueryBestTile :: LispName("x-query-best-tile") + +xCopyGcontext :: LispName("xlib:copy-gcontext") + +-- GRAPHICS OPERATIONS + +xClearArea :: LispName("x-clear-area") +xCopyArea :: LispName("x-copy-area") +xCopyPlane :: LispName("x-copy-plane") +xDrawPoint :: LispName("x-draw-point") +xDrawPoints :: LispName("x-draw-points") +xDrawLine :: LispName("x-draw-line") +xDrawLines :: LispName("x-draw-lines") +xDrawSegments :: LispName("x-draw-segments") +xDrawRectangle :: LispName("x-draw-rectangle") +xDrawRectangles :: LispName("x-draw-rectangles") +xDrawArc :: LispName("x-draw-arc") +xDrawArcs :: LispName("x-draw-arcs") +xDrawGlyph :: LispName("x-draw-glyph") +xDrawGlyphs :: LispName("x-draw-glyphs") +xDrawImageGlyph :: LispName("x-draw-image-glyph") +xDrawImageGlyphs :: LispName("x-draw-image-glyphs") + +-- IMAGES + +xImageBlueMask :: LispName("xlib:image-blue-mask") +xImageDepth :: LispName("xlib:image-depth") +xImageGreenMask :: LispName("xlib:image-green-mask") +xImageSize :: LispName("x-image-size") +xImageName :: LispName("x-image-name") +xSetImageName :: LispName("x-set-image-name") +xImageRedMask :: LispName("xlib:image-red-mask") +xImageHotSpot :: LispName("x-image-hot-spot") +xSetImageHotSpot :: LispName("x-set-image-hot-spot") + +-- XY-format images + +xImageXYBitmaps :: LispName("xlib:image-xy-bitmap-list") +xSetImageXYBitmaps :: LispName("x-set-image-xy-bitmap-list") + +-- Z-format images + +xImageZBitsPerPixel :: LispName("xlib:image-z-bits-per-pixel") +xsetImageZBitsPerPixel :: LispName("x-set-image-z-bits-per-pixel") +xImageZPixarray :: LispName("xlib:image-z-pixarray") +xSetImageZPixarray :: LispName("x-set-image-z-pixarray") + +-- image functions + +xCreateImage :: LispName("x-create-image") +xCopyImage :: LispName("x-copy-image") +xGetImage :: LispName("x-get-image") +xPutImage :: LispName("x-put-image") + +-- image files + +xReadBitmapFile :: LispName("xlib:read-bitmap-file") +xWriteBitmapFile :: LispName("xlib:write-bitmap-file") + +-- direct image transfer + +xGetRawImage :: LispName("x-get-raw-image") +xPutRawImage :: LispName("x-put-raw-image") + +-- FONTS + +-- opening fonts + +xOpenFont :: LispName ("xlib:open-font") +xCloseFont :: LispName ("xlib:close-font") +xDiscardFontInfo :: LispName ("xlib:discard-font-info") + +-- listing fonts + +xFontPath :: LispName ("xlib:font-path") +xListFontNames :: LispName ("xlib:list-font-names") +xListFonts :: LispName ("xlib:list-fonts") + +-- font attriburtes + +xFontAllCharExistsP :: LispName ("xlib:font-all-chars-exist-p") +xFontAscent :: LispName ("xlib:font-ascent") +xFontDefaultChar :: LispName ("xlib:font-default-char") +xFontDescent :: LispName ("xlib:font-descent") +xFontDirection :: LispName ("xlib:font-direction") +xFontDisplay :: LispName ("xlib:font-display") +xFontEqual :: LispName ("xlib:font-equal") +xFontId :: LispName ("xlib:font-id") + +xFontMaxByte1 :: LispName ("xlib:font-max-byte1") +xFontMaxByte2 :: LispName ("xlib:font-max-byte2") +xFontMaxChar :: LispName ("xlib:font-max-char") +xFontMinByte1 :: LispName ("xlib:font-min-byte1") +xFontMinByte2 :: LispName ("xlib:font-min-byte2") +xFontMinChar :: LispName ("xlib:font-min-char") + +xFontName :: LispName ("x-font-name") + +xFontMaxCharAscent :: LispName ("xlib:max-char-ascent") +xFontMaxCharAttributes :: LispName ("xlib:max-char-attributes") +xFontMaxCharDescent :: LispName ("xlib:max-char-descent") +xFontMaxCharLeftBearing :: LispName ("xlib:max-char-left-bearing") +xFontMaxCharRightBearing :: LispName ("xlib:max-char-right-bearing") +xFontMaxCharWidth :: LispName ("xlib:max-char-width") +xFontMinCharAscent :: LispName ("xlib:min-char-ascent") +xFontMinCharAttributes :: LispName ("xlib:min-char-attributes") +xFontMinCharDescent :: LispName ("xlib:min-char-descent") +xFontMinCharLeftBearing :: LispName ("xlib:min-char-left-bearing") +xFontMinCharRightBearing :: LispName ("xlib:min-char-right-bearing") +xFontMinCharWidth :: LispName ("xlib:min-char-width") + +-- char attributes + +xCharAscent :: LispName ("xlib:char-ascent") +xCharAttributes :: LispName ("xlib:char-attributes") +xCharDescent :: LispName ("xlib:char-descent") +xCharLeftBearing :: LispName ("xlib:char-left-bearing") +xCharRightBearing :: LispName ("xlib:char-right-bearing") +xCharWidth :: LispName ("xlib:char-width") + +-- querying text size + +xTextWidth :: LispName ("xlib:text-width") + +-- COLORS + +-- creating colormaps + +xCreateColormap :: LispName ("xlib:create-colormap") +xCopyColormapAndFree :: LispName ("xlib:copy-colormap-and-free") +xFreeColormap :: LispName ("xlib:free-colormap") + +-- installing colormaps + +xInstallColormap :: LispName ("xlib:install-colormap") +xInstalledColormaps :: LispName ("xlib:installed-colormaps") +xUnInstallColormap :: LispName ("xlib:uninstall-colormap") + +-- allocating colors + +xAllocColor :: LispName ("x-alloc-color") +xAllocColorCells :: LispName ("x-alloc-color-cells") +xAllocColorPlanes :: LispName ("x-alloc-color-planes") + +xFreeColors :: LispName ("xlib:free-colors") + +-- finding colors + +xLookupColor :: LispName ("x-lookup-color") +xQueryColors :: LispName ("xlib:query-colors") + +-- changing colors + +xStoreColor :: LispName ("xlib:store-color") +xStoreColors :: LispName ("x-store-colors") + +-- colormap attributes + +xColormapDisplay :: LispName ("xlib:colormap-display") +xColormapEqual :: LispName ("xlib:colormap-equal") + +-- CURSORS + +xCreateCursor :: LispName ("x-create-cursor") +xCreateGlyphCursor :: LispName ("x-create-glyph-cursor") +xFreeCursor :: LispName ("xlib:free-cursor") + +xQueryBestCursor :: LispName ("x-query-best-cursor") +xRecolorCursor :: LispName ("xlib:recolor-cursor") + +xCursorDisplay :: LispName ("xlib:cursor-display") +xCursorEqual :: LispName ("xlib:cursor-equal") + +-- ATOMS, PROPERTIES, AND SELECTIONS + +-- atoms + +xAtomName :: LispName ("xlib:atom-name") +xFindAtom :: LispName ("xlib:find-atom") +xInternAtom :: LispName ("xlib:intern-atom") + +-- properties + +xChangeProperty :: LispName ("x-change-property") +xDeleteProperty :: LispName ("xlib:delete-property") +xGetProperty :: LispName ("x-get-property") +xListProperties :: LispName ("xlib:list-properties") +xRotateProperties :: LispName ("xlib:rotate-properties") + +-- selections + +xConvertSelection :: LispName ("x-convert-selection") +xSelectionOwner :: LispName ("xlib:selection-owner") +xSetSelectionOwner :: LispName ("x-set-selection-owner") + +-- EVENT + +-- Wait for the next event + +xGetEvent :: LispName ("x-get-event") + +-- managing the event queue + +xQueueEvent :: LispName ("x-queue-event") +xEventListen :: LispName ("x-event-listen") + +-- sending events + +xSendEvent :: LispName ("x-send-event") + +-- pointer position + +xGlobalPointerPosition :: LispName ("x-global-pointer-position") +xPointerPosition :: LispName ("x-pointer-position") +xMotionEvents :: LispName ("x-motion-events") +xWarpPointer :: LispName ("x-warp-pointer") + +-- keyboard input focus + +xSetInputFocus :: LispName ("x-set-input-focus") +xInputFucus :: LispName ("x-input-focus") + +-- grabbing the pointer + +xGrabPointer :: LispName ("x-grab-pointer") +xUngrabPointer :: LispName ("x-ungrab-pointer") +xChangeActivePointerGrab :: LispName ("x-change-active-pointer-grab") + +-- grabbing a button + +xGrabButton :: LispName ("x-grab-button") +xUngrabButton :: LispName ("x-ungrab-button") + +-- grabbing the keyboard + +xGrabKeyboard :: LispName ("x-grab-keyboard") +xUngrabkeyboard :: LispName ("x-ungrab-keyboard") + +-- grabbing a key + +xGrabKey :: LispName ("x-grab-key") +xUngrabKey :: LispName ("x-ungrab-key") + +-- CONTROL FUNCTIONS + +-- grabbing the server + +xGrabServer :: LispName ("xlib:grab-server") +xUngrabServer :: LispName ("xlib:ungrab-server") + +-- pointer control + +xSetPointerAcceleration :: LispName ("x-set-pointer-acceleration") +xSetPointerThreshold :: LispName ("x-set-pointer-threshold") +xPointerAcceleration :: LispName ("x-pointer-acceleration") +xPointerThreshold :: LispName ("x-pointer-threshold") +xSetPointerMapping :: LispName ("x-set-pointer-mapping") +xPointerMapping :: LispName ("xlib:pointer-mapping") + +-- keyboard control + +xBell :: LispName ("xlib:bell") + +xSetKeyboardKeyClickPercent :: LispName ("x-set-keyboard-key-click-percent") +xSetKeyboardBellPercent :: LispName ("x-set-keyboard-bell-percent") +xSetKeyboardBellPitch :: LispName ("x-set-keyboard-bell-pitch") +xSetKeyboardBellDuration :: LispName ("x-set-keyboard-bell-duration") +xSetKeyboardLed :: LispName ("x-set-keyboard-led") +xSetKeyboardAutoRepeatMode :: LispName ("x-set-keyboard-auto-repeat-mode") + +xKeyboardKeyClickPercent :: LispName ("x-keyboard-key-click-percent") +xKeyboardBellPercent :: LispName ("x-keyboard-bell-percent") +xKeyboardBellPitch :: LispName ("x-keyboard-bell-pitch") +xKeyboardBellDuration :: LispName ("x-keyboard-bell-duration") +xKeyboardLed :: LispName ("x-keyboard-led") +xKeyboardAutoRepeatMode :: LispName ("x-keyboard-auto-repeat-mode") + +xModifierMapping :: LispName ("x-modifier-mapping") +xSetModifierMapping :: LispName ("x-set-modifier-mapping") +xQueryKeymap :: LispName ("xlib:query-keymap") + +-- keyboard mapping + +xChangeKeyboardMapping :: LispName ("xlib:change-keyboard-mapping") +xKeyboardMapping :: LispName ("xlib:keyboard-mapping") + +xKeycodeKeysym :: LispName ("xlib:keycode->keysym") +xKeysymCharacter :: LispName ("x-keysym-character") +xKeycodeCharacter :: LispName ("x-keycode-character") + +-- client termination + +xAddToSaveSet :: LispName ("xlib:add-to-save-set") +xCloseDownMode :: LispName ("xlib:close-down-mode") +xSetCloseDownMode :: LispName ("x-set-close-down-mode") +xKillClient :: LispName ("xlib:kill-client") +xKillTemporaryClients :: LispName ("xlib:kill-temporary-clients") +xRemoveFromSaveSet :: LispName ("xlib:remove-from-save-set") + +-- managing host access + +xAccessControl :: LispName ("xlib:access-control") +xSetAccessControl :: LispName ("x-set-access-control") +xAccessHosts :: LispName ("xlib:access-hosts") +xAddAccessHost :: LispName ("xlib:add-access-host") +xRemoveAccessHost :: LispName ("xlib:remove-access-host") + +-- screen saver + +xActivateScreenSaver :: LispName ("xlib:activate-screen-saver") +xResetScreenSaver :: LispName ("xlib:reset-screen-saver") +xScreenSaver :: LispName ("x-screen-saver") +xSetScreenSaver :: LispName ("x-set-screen-saver") + +#-} + +data XMArray a + +xMArrayCreate :: [a] -> IO (XMArray a) +xMArrayLookup :: XMArray a -> Int -> IO a +xMArrayUpdate :: XMArray a -> Int -> a -> IO () +xMArrayLength :: XMArray a -> Int + +{-# +xMArrayCreate :: LispName("x-mutable-array-create") +xMArrayLookup :: LispName("x-mutable-array-lookup") +xMArrayUpdate :: LispName("x-mutable-array-update") +xMArrayLength :: LispName("x-mutable-array-length") +#-} + + +xprint :: a -> IO () +{-# +xprint :: LispName ("x-print") +#-} + +-- decoded time format: +-- ([second, minute, hour, date, month, year, day-of-week], +-- daylight-saving-time-p) +-- time format to encode: +-- [second, minute, hour, date, month, year] + +data TimeZone = WestOfGMT Int {-# STRICT #-} + | CurrentZone + +getTime :: IO Integer +getTimeZone :: IO Int +decodeTime :: Integer -> TimeZone -> ([Int], Bool) +encodeTime :: [Int] -> TimeZone -> Integer +getRunTime :: IO Float +getElapsedTime :: IO Float +sleep :: Int -> IO () + +{-# +ImportLispType (TimeZone (WestOfGMT ("number?", "identity", "identity"))) +ImportLispType (TimeZone (CurrentZone ("null?", "'()"))) + +getTime :: LispName("lisp:get-universal-time") +getTimeZone :: LispName("get-time-zone") +decodeTime :: LispName("decode-time") +encodeTime :: LispName("encode-time") +getRunTime :: LispName("get-run-time") +getElapsedTime :: LispName("get-elapsed-time") +sleep :: LispName("lisp:sleep") + +#-} + +xWmName :: XWindow -> IO String +xSetWmName :: XWindow -> String -> IO () + +xWmIconName :: XWindow -> IO String +xSetWmIconName :: XWindow -> String -> IO () + +{-# +xWmName :: LispName ("xlib:wm-name") +xSetWmName :: LispName ("x-set-wm-name") + +xWmIconName :: LispName ("xlib:wm-icon-name") +xSetWmIconName :: LispName ("x-set-wm-icon-name") +#-} diff --git a/progs/lib/X11/xlibprims.hu b/progs/lib/X11/xlibprims.hu new file mode 100644 index 0000000..38138d4 --- /dev/null +++ b/progs/lib/X11/xlibprims.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:stable +:o= all +xlibclx.scm +xlibprims.hi diff --git a/progs/lib/cl/README b/progs/lib/cl/README new file mode 100644 index 0000000..8164257 --- /dev/null +++ b/progs/lib/cl/README @@ -0,0 +1,2 @@ +This directory contains some libraries which allow you to use various +Common Lisp primitives from Haskell. diff --git a/progs/lib/cl/logop-prims.hi b/progs/lib/cl/logop-prims.hi new file mode 100644 index 0000000..2b120bb --- /dev/null +++ b/progs/lib/cl/logop-prims.hi @@ -0,0 +1,78 @@ +-- logop-prims.hi -- interface to logical operations on numbers +-- +-- author : Sandra Loosemore +-- date : 19 June 1993 +-- + +interface LogOpPrims where + +logiorInteger :: Integer -> Integer -> Integer +logxorInteger :: Integer -> Integer -> Integer +logandInteger :: Integer -> Integer -> Integer +logeqvInteger :: Integer -> Integer -> Integer +lognandInteger :: Integer -> Integer -> Integer +lognorInteger :: Integer -> Integer -> Integer +logandc1Integer :: Integer -> Integer -> Integer +logandc2Integer :: Integer -> Integer -> Integer +logorc1Integer :: Integer -> Integer -> Integer +logorc2Integer :: Integer -> Integer -> Integer +lognotInteger :: Integer -> Integer +logtestInteger :: Integer -> Integer -> Integer +logbitpInteger :: Int -> Integer -> Integer +ashInteger :: Integer -> Int -> Integer +logcountInteger :: Integer -> Int +integerLengthInteger :: Integer -> Int + +logiorInt :: Int -> Int -> Int +logxorInt :: Int -> Int -> Int +logandInt :: Int -> Int -> Int +logeqvInt :: Int -> Int -> Int +lognandInt :: Int -> Int -> Int +lognorInt :: Int -> Int -> Int +logandc1Int :: Int -> Int -> Int +logandc2Int :: Int -> Int -> Int +logorc1Int :: Int -> Int -> Int +logorc2Int :: Int -> Int -> Int +lognotInt :: Int -> Int +logtestInt :: Int -> Int -> Int +logbitpInt :: Int -> Int -> Int +ashInt :: Int -> Int -> Int +logcountInt :: Int -> Int +integerLengthInt :: Int -> Int + +{-# +logiorInteger :: LispName("logop.logior-integer"), Complexity(4) +logxorInteger :: LispName("logop.logxor-integer"), Complexity(4) +logandInteger :: LispName("logop.logand-integer"), Complexity(4) +logeqvInteger :: LispName("logop.logeqv-integer"), Complexity(4) +lognandInteger :: LispName("logop.lognand-integer"), Complexity(4) +lognorInteger :: LispName("logop.lognor-integer"), Complexity(4) +logandc1Integer :: LispName("logop.logandc1-integer"), Complexity(4) +logandc2Integer :: LispName("logop.logandc2-integer"), Complexity(4) +logorc1Integer :: LispName("logop.logorc1-integer"), Complexity(4) +logorc2Integer :: LispName("logop.logorc2-integer"), Complexity(4) +lognotInteger :: LispName("logop.lognot-integer"), Complexity(4) +logtestInteger :: LispName("logop.logtest-integer"), Complexity(4) +logbitpInteger :: LispName("logop.logbitp-integer"), Complexity(4) +ashInteger :: LispName("logop.ash-integer"), Complexity(4) +logcountInteger :: LispName("logop.logcount-integer"), Complexity(4) +integerLengthInteger :: LispName("logop.integer-length-integer"), Complexity(4) + +logiorInt :: LispName("logop.logior-int"), Complexity(2) +logxorInt :: LispName("logop.logxor-int"), Complexity(2) +logandInt :: LispName("logop.logand-int"), Complexity(2) +logeqvInt :: LispName("logop.logeqv-int"), Complexity(2) +lognandInt :: LispName("logop.lognand-int"), Complexity(2) +lognorInt :: LispName("logop.lognor-int"), Complexity(2) +logandc1Int :: LispName("logop.logandc1-int"), Complexity(2) +logandc2Int :: LispName("logop.logandc2-int"), Complexity(2) +logorc1Int :: LispName("logop.logorc1-int"), Complexity(2) +logorc2Int :: LispName("logop.logorc2-int"), Complexity(2) +lognotInt :: LispName("logop.lognot-int"), Complexity(2) +logtestInt :: LispName("logop.logtest-int"), Complexity(2) +logbitpInt :: LispName("logop.logbitp-int"), Complexity(2) +ashInt :: LispName("logop.ash-int"), Complexity(2) +logcountInt :: LispName("logop.logcount-int"), Complexity(2) +integerLengthInt :: LispName("logop.integer-length-int"), Complexity(2) +#-} + diff --git a/progs/lib/cl/logop-prims.scm b/progs/lib/cl/logop-prims.scm new file mode 100644 index 0000000..b846836 --- /dev/null +++ b/progs/lib/cl/logop-prims.scm @@ -0,0 +1,81 @@ +;;; logop-prims.scm -- primitives for logical operations on numbers +;;; +;;; author : Sandra Loosemore +;;; date : 19 Jun 1993 +;;; + + +;;; Integer operations +;;; Note that bit counts are still guaranteed to be fixnums.... + +(define-syntax (logop.logior-integer i1 i2) + `(the integer (lisp:logior (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logxor-integer i1 i2) + `(the integer (lisp:logxor (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logand-integer i1 i2) + `(the integer (lisp:logand (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logeqv-integer i1 i2) + `(the integer (lisp:logeqv (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognand-integer i1 i2) + `(the integer (lisp:lognand (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognor-integer i1 i2) + `(the integer (lisp:lognor (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logandc1-integer i1 i2) + `(the integer (lisp:logandc1 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logandc2-integer i1 i2) + `(the integer (lisp:logandc2 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logorc1-integer i1 i2) + `(the integer (lisp:logorc1 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logorc2-integer i1 i2) + `(the integer (lisp:logorc2 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognot-integer i1) + `(the integer (lisp:lognot (the integer ,i1)))) +(define-syntax (logop.logtest-integer i1 i2) + `(the integer (lisp:logtest (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logbitp-integer i1 i2) + `(the integer (lisp:logbitp (the fixnum ,i1) (the integer ,i2)))) +(define-syntax (logop.ash-integer i1 i2) + `(the integer (lisp:ash (the integer ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logcount-integer i1) + `(the fixnum (lisp:logcount (the integer ,i1)))) +(define-syntax (logop.integer-length-integer i1) + `(the fixnum (lisp:integer-length (the integer ,i1)))) + + +;;; Fixnum operations + +(define-syntax (logop.logior-int i1 i2) + `(the fixnum (lisp:logior (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logxor-int i1 i2) + `(the fixnum (lisp:logxor (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logand-int i1 i2) + `(the fixnum (lisp:logand (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logeqv-int i1 i2) + `(the fixnum (lisp:logeqv (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognand-int i1 i2) + `(the fixnum (lisp:lognand (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognor-int i1 i2) + `(the fixnum (lisp:lognor (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logandc1-int i1 i2) + `(the fixnum (lisp:logandc1 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logandc2-int i1 i2) + `(the fixnum (lisp:logandc2 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logorc1-int i1 i2) + `(the fixnum (lisp:logorc1 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logorc2-int i1 i2) + `(the fixnum (lisp:logorc2 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognot-int i1) + `(the fixnum (lisp:lognot (the fixnum ,i1)))) +(define-syntax (logop.logtest-int i1 i2) + `(the fixnum (lisp:logtest (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logbitp-int i1 i2) + `(the fixnum (lisp:logbitp (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.ash-int i1 i2) + `(the fixnum (lisp:ash (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logcount-int i1) + `(the fixnum (lisp:logcount (the fixnum ,i1)))) +(define-syntax (logop.integer-length-int i1) + `(the fixnum (lisp:integer-length (the fixnum ,i1)))) + + + diff --git a/progs/lib/cl/logop.hs b/progs/lib/cl/logop.hs new file mode 100644 index 0000000..1d0f9ba --- /dev/null +++ b/progs/lib/cl/logop.hs @@ -0,0 +1,63 @@ +-- logop.hs -- logical operations on numbers +-- +-- author : Sandra Loosemore +-- date : 19 June 1993 +-- + +module LogOp where + +import LogOpPrims -- from logop-prims.hi + +class LogOperand a where + logior :: a -> a -> a + logxor :: a -> a -> a + logand :: a -> a -> a + logeqv :: a -> a -> a + lognand :: a -> a -> a + lognor :: a -> a -> a + logandc1 :: a -> a -> a + logandc2 :: a -> a -> a + logorc1 :: a -> a -> a + logorc2 :: a -> a -> a + lognot :: a -> a + logtest :: a -> a -> a + logbitp :: Int -> a -> a + ash :: a -> Int -> a + logcount :: a -> Int + integerLength :: a -> Int + +instance LogOperand Integer where + logior = logiorInteger + logxor = logxorInteger + logand = logandInteger + logeqv = logeqvInteger + lognand = lognandInteger + lognor = lognorInteger + logandc1 = logandc1Integer + logandc2 = logandc2Integer + logorc1 = logorc1Integer + logorc2 = logorc2Integer + lognot = lognotInteger + logtest = logtestInteger + logbitp = logbitpInteger + ash = ashInteger + logcount = logcountInteger + integerLength = integerLengthInteger + +instance LogOperand Int where + logior = logiorInt + logxor = logxorInt + logand = logandInt + logeqv = logeqvInt + lognand = lognandInt + lognor = lognorInt + logandc1 = logandc1Int + logandc2 = logandc2Int + logorc1 = logorc1Int + logorc2 = logorc2Int + lognot = lognotInt + logtest = logtestInt + logbitp = logbitpInt + ash = ashInt + logcount = logcountInt + integerLength = integerLengthInt diff --git a/progs/lib/cl/logop.hu b/progs/lib/cl/logop.hu new file mode 100644 index 0000000..cfe8209 --- /dev/null +++ b/progs/lib/cl/logop.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:o= all +logop.hs +logop-prims.scm +logop-prims.hi diff --git a/progs/lib/cl/maybe.hs b/progs/lib/cl/maybe.hs new file mode 100644 index 0000000..8ce01e5 --- /dev/null +++ b/progs/lib/cl/maybe.hs @@ -0,0 +1,12 @@ +-- maybe.hs -- "maybe" type +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + +module Maybe where + +data Maybe a = Some a | Null + +{-# ImportLispType (Maybe(Some("identity", "identity", "identity"), + Null("not", "'#f"))) #-} diff --git a/progs/lib/cl/maybe.hu b/progs/lib/cl/maybe.hu new file mode 100644 index 0000000..2115c71 --- /dev/null +++ b/progs/lib/cl/maybe.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +maybe.hs diff --git a/progs/lib/cl/random-prims.hi b/progs/lib/cl/random-prims.hi new file mode 100644 index 0000000..e66d802 --- /dev/null +++ b/progs/lib/cl/random-prims.hi @@ -0,0 +1,20 @@ +-- random-prims.hi -- interface file to random number primitives +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + + +interface RandomPrims where + +randomInt :: Int -> IO Int +randomInteger :: Integer -> IO Integer +randomFloat :: Float -> IO Float +randomDouble :: Double -> IO Double + +{-# +randomInt :: LispName("lisp:random"), Complexity(5) +randomInteger :: LispName("lisp:random"), Complexity(5) +randomFloat :: LispName("lisp:random"), Complexity(5) +randomDouble :: LispName("lisp:random"), Complexity(5) +#-} diff --git a/progs/lib/cl/random.hs b/progs/lib/cl/random.hs new file mode 100644 index 0000000..93d26e4 --- /dev/null +++ b/progs/lib/cl/random.hs @@ -0,0 +1,21 @@ +-- random.hs -- random number functions +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + +module Random where + +import RandomPrims -- from random-prims.hi + +class RandomOperand a where + random :: a -> IO a + +instance RandomOperand Int where + random = randomInt +instance RandomOperand Integer where + random = randomInteger +instance RandomOperand Float where + random = randomFloat +instance RandomOperand Double where + random = randomDouble diff --git a/progs/lib/cl/random.hu b/progs/lib/cl/random.hu new file mode 100644 index 0000000..4b8e286 --- /dev/null +++ b/progs/lib/cl/random.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +random.hs +random-prims.hi diff --git a/progs/lib/hbc/Either.hs b/progs/lib/hbc/Either.hs new file mode 100644 index 0000000..fad5af8 --- /dev/null +++ b/progs/lib/hbc/Either.hs @@ -0,0 +1,2 @@ +module Either(Either(..)) where +data Either a b = Left a | Right b deriving (Eq, Ord, Text, Binary) diff --git a/progs/lib/hbc/Either.hu b/progs/lib/hbc/Either.hu new file mode 100644 index 0000000..3313235 --- /dev/null +++ b/progs/lib/hbc/Either.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Either.hs diff --git a/progs/lib/hbc/Hash.hs b/progs/lib/hbc/Hash.hs new file mode 100644 index 0000000..1f14c6f --- /dev/null +++ b/progs/lib/hbc/Hash.hs @@ -0,0 +1,79 @@ +module Hash where +-- +-- Hash a value. Hashing produces an Int of +-- unspecified range. +-- + +class Hashable a where + hash :: a -> Int + +instance Hashable Char where + hash x = ord x + +instance Hashable Int where + hash x = x + +instance Hashable Integer where + hash x = fromInteger x + +instance Hashable Float where + hash x = truncate x + +instance Hashable Double where + hash x = truncate x + +instance Hashable Bin where + hash x = 0 + +{-instance Hashable File where + hash x = 0 -} + +instance Hashable () where + hash x = 0 + +instance Hashable (a -> b) where + hash x = 0 + +instance Hashable a => Hashable [a] where + hash x = sum (map hash x) + +instance (Hashable a, Hashable b) => Hashable (a,b) where + hash (a,b) = hash a + 3 * hash b + +instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where + hash (a,b,c) = hash a + 3 * hash b + 5 * hash c + +instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where + hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d + +instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where + hash (a,b,c,d,e) = hash a + hash b + hash c + hash d + hash e + +instance Hashable Bool where + hash False = 0 + hash True = 1 + +instance (Integral a, Hashable a) => Hashable (Ratio a) where + hash x = hash (denominator x) + hash (numerator x) + +instance (RealFloat a, Hashable a) => Hashable (Complex a) where + hash (x :+ y) = hash x + hash y + +instance (Hashable a, Hashable b) => Hashable (Assoc a b) where + hash (x := y) = hash x + hash y + +instance (Ix a) => Hashable (Array a b) where + hash x = 0 -- !!! + +instance Hashable Request where + hash x = 0 -- !! + +instance Hashable Response where + hash x = 0 -- !! + +instance Hashable IOError where + hash x = 0 -- !! + +hashToMax maxhash x = + let h = abs (hash x) + in if h < 0 then 0 else h `rem` maxhash diff --git a/progs/lib/hbc/Hash.hu b/progs/lib/hbc/Hash.hu new file mode 100644 index 0000000..2c23c72 --- /dev/null +++ b/progs/lib/hbc/Hash.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Hash.hs diff --git a/progs/lib/hbc/ListUtil.hs b/progs/lib/hbc/ListUtil.hs new file mode 100644 index 0000000..560920e --- /dev/null +++ b/progs/lib/hbc/ListUtil.hs @@ -0,0 +1,48 @@ +module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..) where +import Maybe + +-- Lookup an item in an association list. Apply a function to it if it is found, otherwise return a default value. +assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b +assoc f d [] x = d +assoc f d ((x',y):xys) x | x' == x = f y + | otherwise = assoc f d xys x + +-- Map and concatename results. +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f [] = [] +concatMap f (x:xs) = + case f x of + [] -> concatMap f xs + ys -> ys ++ concatMap f xs + +-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values. +unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] +unfoldr f p x | p x = [] + | otherwise = y:unfoldr f p x' + where (y, x') = f x + +-- Map, but plumb a state through the map operation. +mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccuml f s [] = (s, []) +mapAccuml f s (x:xs) = (s'', y:ys) + where (s', y) = f s x + (s'', ys) = mapAccuml f s' xs + +-- Union of sets as lists. +union :: (Eq a) => [a] -> [a] -> [a] +union xs ys = xs ++ (ys \\ xs) + +-- Intersection of sets as lists. +intersection :: (Eq a) => [a] -> [a] -> [a] +intersection xs ys = [x | x<-xs, x `elem` ys] + +--- Functions derived from those above + +chopList :: ([a] -> (b, [a])) -> [a] -> [b] +chopList f l = unfoldr f null l + +assocDef :: (Eq a) => [(a, b)] -> b -> a -> b +assocDef l d x = assoc id d l x + +lookup :: (Eq a) => [(a, b)] -> a -> Maybe b +lookup l x = assoc Just Nothing l x diff --git a/progs/lib/hbc/ListUtil.hu b/progs/lib/hbc/ListUtil.hu new file mode 100644 index 0000000..7402cb7 --- /dev/null +++ b/progs/lib/hbc/ListUtil.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +ListUtil.hs +Maybe.hu diff --git a/progs/lib/hbc/Maybe.hs b/progs/lib/hbc/Maybe.hs new file mode 100644 index 0000000..f0ada70 --- /dev/null +++ b/progs/lib/hbc/Maybe.hs @@ -0,0 +1,6 @@ +module Maybe(Maybe(..), thenM) where +-- Maybe together with Just and thenM forms a monad, but is more +-- by accident than by design. +data Maybe a = Nothing | Just a deriving (Eq, Ord, Text, Binary) +Nothing `thenM` _ = Nothing +Just a `thenM` f = f a diff --git a/progs/lib/hbc/Maybe.hu b/progs/lib/hbc/Maybe.hu new file mode 100644 index 0000000..a55b652 --- /dev/null +++ b/progs/lib/hbc/Maybe.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Maybe.hs diff --git a/progs/lib/hbc/Miranda.hs b/progs/lib/hbc/Miranda.hs new file mode 100644 index 0000000..2d863ce --- /dev/null +++ b/progs/lib/hbc/Miranda.hs @@ -0,0 +1,90 @@ +module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces, + {-force,seq,-}sort) where +--import UnsafeDirty +import QSort + +cjustify :: Int -> String -> String +cjustify n s = spaces l ++ s ++ spaces r + where + m = n - length s + l = m `div` 2 + r = m - l + +{- +index :: [a] -> [Int] +index xs = f xs 0 + where f [] n = [] + f (_:xs) n = n : f xs (n+1) +-} + +lay :: [String] -> String +lay = concat . map (++"\n") + +layn :: [String] -> String +layn = concat . zipWith f [1..] + where + f :: Int -> String -> String + f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n" + +limit :: (Eq a) => [a] -> a +limit (x:y:ys) | x == y = x + | otherwise = limit (y:ys) +limit _ = error "Miranda.limit: bad use" + +ljustify :: Int -> String -> String +ljustify n s = s ++ spaces (n - length s) + +merge :: (Ord a) => [a] -> [a] -> [a] +merge [] ys = ys +merge xs [] = xs +merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys + | otherwise = y : merge xxs ys + +rep :: Int -> b -> [b] +rep n x = take n (repeat x) + +rjustify :: Int -> String -> String +rjustify n s = spaces (n - length s) ++ s + +spaces :: Int -> String +spaces 0 = "" +spaces n = ' ' : spaces (n-1) + +------------- + +arctan x = atan x +code c = ord c +converse f a b = flip f a b +decode n = chr n +digit c = isDigit c +e :: (Floating a) => a +e = exp 1 +entier x = floor x +filemode f = error "Miranda.filemode" +--getenv +hd xs = head xs +hugenum :: (Floating a) => a +hugenum = error "hugenum" --!!! +integer x = x == truncate x +letter c = isAlpha c +map2 f xs ys = zipWith f xs ys +--max +max2 x y = max x y +member xs x = x `elem` xs +--min +min2 x y = min x y +mkset xs = nub xs +neg x = negate x +numval :: (Num a) => String -> a +numval cs = read cs +postfix xs x = xs ++ [x] +--read +scan f z l = scanl f z l +--shownum !!! +--showfloat !!! +--showscaled !!! +tinynum :: (Floating a) => a +tinynum = error "tinynum" +undef = error "undefined" +zip2 xs ys = zip xs ys +--zip diff --git a/progs/lib/hbc/Miranda.hu b/progs/lib/hbc/Miranda.hu new file mode 100644 index 0000000..cfa86ed --- /dev/null +++ b/progs/lib/hbc/Miranda.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +Miranda.hs +QSort.hu diff --git a/progs/lib/hbc/Option.hs b/progs/lib/hbc/Option.hs new file mode 100644 index 0000000..a4b2423 --- /dev/null +++ b/progs/lib/hbc/Option.hs @@ -0,0 +1,3 @@ +module Option(Option(..), thenO) where +import Maybe renaming (Maybe to Option, Nothing to None, Just to Some, thenM to thenO) + diff --git a/progs/lib/hbc/Option.hu b/progs/lib/hbc/Option.hu new file mode 100644 index 0000000..592a0cd --- /dev/null +++ b/progs/lib/hbc/Option.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Option.hs diff --git a/progs/lib/hbc/Pretty.hs b/progs/lib/hbc/Pretty.hs new file mode 100644 index 0000000..ad63dbe --- /dev/null +++ b/progs/lib/hbc/Pretty.hs @@ -0,0 +1,50 @@ +module Pretty(text, separate, nest, pretty, (~.), (^.), IText(..), Context(..)) where +infixr 8 ~. +infixr 8 ^. + +type IText = Context -> [String] +type Context = (Bool,Int,Int,Int) + +text :: String -> IText +text s (v,w,m,m') = [s] + +(~.) :: IText -> IText -> IText +(~.) d1 d2 (v,w,m,m') = + let t = d1 (False,w,m,m') + tn = last t + indent = length tn + sig = if length t == 1 + then m' + indent + else length (dropWhile (==' ') tn) + (l:ls) = d2 (False,w-indent,m,sig) + in init t ++ + [tn ++ l] ++ + map (space indent++) ls + +space :: Int -> String +space n = [' ' | i<-[1..n]] + +(^.) :: IText -> IText -> IText +(^.) d1 d2 (v,w,m,m') = d1 (True,w,m,m') ++ d2 (True,w,m,0) + +separate :: [IText] -> IText +separate [] _ = [""] +separate ds (v,w,m,m') = + let hor = foldr1 (\d1 d2 -> d1 ~. text " " ~. d2) ds + ver = foldr1 (^.) ds + t = hor (v,w,m,m') + in if fits 1 t && fits (w `min` m-m') (head t) + then t + else ver (v,w,m,m') + +fits n xs = length xs <= n `max` 0 --null (drop n xs) + +nest :: Int -> IText -> IText +nest n d (v,w,m,m') = + if v then + map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n)) + else + d (v,w,m,m') + +pretty :: Int->Int->IText->String +pretty w m d = concat (map (++"\n") (d (False,w,m,0))) diff --git a/progs/lib/hbc/Printf.hs b/progs/lib/hbc/Printf.hs new file mode 100644 index 0000000..c8291bd --- /dev/null +++ b/progs/lib/hbc/Printf.hs @@ -0,0 +1,150 @@ +-- This code used a function in the lml library (fmtf) that I don't have. +-- If someone makes this work for floats let me know -- jcp +-- +-- A C printf like formatter. +-- Conversion specs: +-- - left adjust +-- num field width +-- . separates width from precision +-- Formatting characters: +-- c Char, Int, Integer +-- d Char, Int, Integer +-- o Char, Int, Integer +-- x Char, Int, Integer +-- u Char, Int, Integer +-- f Float, Double +-- g Float, Double +-- e Float, Double +-- s String +-- +module Printf(UPrintf(..), printf) where + +-- import LMLfmtf + +data UPrintf = UChar Char | + UString String | + UInt Int | + UInteger Integer | + UFloat Float | + UDouble Double + +printf :: String -> [UPrintf] -> String +printf "" [] = "" +printf "" (_:_) = fmterr +printf ('%':_) [] = argerr +printf ('%':cs) us@(_:_) = fmt cs us +printf (c:cs) us = c:printf cs us + +fmt :: String -> [UPrintf] -> String +fmt cs us = + let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us + adjust (pre, str) = + let lstr = length str + lpre = length pre + fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else "" + in if ladj then pre ++ str ++ fill else pre ++ fill ++ str + in + case cs' of + [] -> fmterr + c:cs'' -> + case us' of + [] -> argerr + u:us'' -> + (case c of + 'c' -> adjust ("", [chr (toint u)]) + 'd' -> adjust (fmti u) + 'x' -> adjust ("", fmtu 16 u) + 'o' -> adjust ("", fmtu 8 u) + 'u' -> adjust ("", fmtu 10 u) + '%' -> "%" + 'e' -> adjust (dfmt c prec (todbl u)) + 'f' -> adjust (dfmt c prec (todbl u)) + 'g' -> adjust (dfmt c prec (todbl u)) + 's' -> adjust ("", tostr u) + c -> perror ("bad formatting char " ++ [c]) + ) ++ printf cs'' us'' +unimpl = perror "unimplemented" + +fmti (UInt i) = if i < 0 then + if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i)) + else + ("", itos i) +fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i) +fmti (UChar c) = fmti (UInt (ord c)) +fmti u = baderr + +fmtu b (UInt i) = if i < 0 then + if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i)) + else + itosb b (toInteger i) +fmtu b (UInteger i) = itosb b i +fmtu b (UChar c) = itosb b (toInteger (ord c)) +fmtu b u = baderr + +maxi :: Integer +maxi = (toInteger maxInt + 1) * 2 + +toint (UInt i) = i +toint (UInteger i) = toInt i +toint (UChar c) = ord c +toint u = baderr + +tostr (UString s) = s +tostr u = baderr + +todbl (UDouble d) = d +todbl (UFloat f) = fromRational (toRational f) +todbl u = baderr + +itos n = + if n < 10 then + [chr (ord '0' + toInt n)] + else + let (q, r) = quotRem n 10 in + itos q ++ [chr (ord '0' + toInt r)] + +chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef") +itosb :: Integer -> Integer -> String +itosb b n = + if n < b then + [chars!n] + else + let (q, r) = quotRem n b in + itosb b q ++ [chars!r] + +stoi :: Int -> String -> (Int, String) +stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs +stoi a cs = (a, cs) + +getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf]) +getSpecs l z ('-':cs) us = getSpecs True z cs us +getSpecs l z ('0':cs) us = getSpecs l True cs us +getSpecs l z ('*':cs) us = unimpl +getSpecs l z cs@(c:_) us | isDigit c = + let (n, cs') = stoi 0 cs + (p, cs'') = case cs' of + '.':r -> stoi 0 r + _ -> (-1, cs') + in (n, p, l, z, cs'', us) +getSpecs l z cs us = (0, -1, l, z, cs, us) + +-- jcp: I don't know what the lml function fmtf does. Someone needs to +-- rewrite this. + +{- +dfmt c p d = + case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of + '-':cs -> ("-", cs) + cs -> ("" , cs) +-} +dfmt = error "fmtf not implemented" + +perror s = error ("Printf.printf: "++s) +fmterr = perror "formatting string ended prematurely" +argerr = perror "argument list ended prematurely" +baderr = perror "bad argument" + +-- This is needed because standard Haskell does not have toInt + +toInt :: Integral a => a -> Int +toInt x = fromIntegral x diff --git a/progs/lib/hbc/Printf.hu b/progs/lib/hbc/Printf.hu new file mode 100644 index 0000000..d94f5b1 --- /dev/null +++ b/progs/lib/hbc/Printf.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Printf.hs diff --git a/progs/lib/hbc/QSort.hs b/progs/lib/hbc/QSort.hs new file mode 100644 index 0000000..f19eb43 --- /dev/null +++ b/progs/lib/hbc/QSort.hs @@ -0,0 +1,47 @@ +{- + This module implements a sort function using a variation on + quicksort. It is stable, uses no concatenation and compares + only with <=. + + sortLe sorts with a given predicate + sort uses the <= method + + Author: Lennart Augustsson +-} + +module QSort(sortLe, sort) where +sortLe :: (a -> a -> Bool) -> [a] -> [a] +sortLe le l = qsort le l [] + +sort :: (Ord a) => [a] -> [a] +sort l = qsort (<=) l [] + +-- qsort is stable and does not concatenate. +qsort le [] r = r +qsort le [x] r = x:r +qsort le (x:xs) r = qpart le x xs [] [] r + +-- qpart partitions and sorts the sublists +qpart le x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort le rlt (x:rqsort le rge r) +qpart le x (y:ys) rlt rge r = + if le x y then + qpart le x ys rlt (y:rge) r + else + qpart le x ys (y:rlt) rge r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort le [] r = r +rqsort le [x] r = x:r +rqsort le (x:xs) r = rqpart le x xs [] [] r + +rqpart le x [] rle rgt r = + qsort le rle (x:qsort le rgt r) +rqpart le x (y:ys) rle rgt r = + if le y x then + rqpart le x ys (y:rle) rgt r + else + rqpart le x ys rle (y:rgt) r + diff --git a/progs/lib/hbc/QSort.hu b/progs/lib/hbc/QSort.hu new file mode 100644 index 0000000..9a07dd1 --- /dev/null +++ b/progs/lib/hbc/QSort.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +QSort.hs diff --git a/progs/lib/hbc/README b/progs/lib/hbc/README new file mode 100644 index 0000000..c51452a --- /dev/null +++ b/progs/lib/hbc/README @@ -0,0 +1,97 @@ +These libraries are adapted from the lml library. Also included are a number +of Common Lisp functions. + +The hbc library contains the following modules and functions: + +* module Either + binary sum data type + data Either a b = Left a | Right b + constructor Left typically used for errors + +* module Option + type for success or failure + data Option a = None | Some a + thenO :: Option a -> (a -> Option b) -> Option b apply a function that may fail + + +* module ListUtil + Various useful functions involving lists that are missing from the Prelude + assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b + assoc f d l k looks for k in the association list l, if it is found f is applied to the value, otherwise d is returned + concatMap :: (a -> [b]) -> [a] -> [b] + flattening map (LMLs concmap) + unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] + unfoldr f p x repeatedly applies f to x until (p x) holds. (f x) should give a list element and a new x + mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) + mapAccuml f s l maps f over l, but also threads the state s though (LMLs mapstate) + union :: (Eq a) => [a] -> [a] -> [a] + unions of two lists + intersection :: (Eq a) => [a] -> [a] -> [a] + intersection of two lists + chopList :: ([a] -> (b, [a])) -> [a] -> [b] + LMLs choplist + assocDef :: (Eq a) => [(a, b)] -> b -> a -> b + LMLs assocdef + lookup :: (Eq a) => [(a, b)] -> a -> Option b + lookup l k looks for the key k in the association list l and returns an optional value + +* module Pretty + John Hughes pretty printing library. + type Context = (Bool, Int, Int, Int) + type IText = Context -> [String] + text :: String -> IText just text + (~.) :: IText -> IText -> IText horizontal composition + (^.) :: IText -> IText -> IText vertical composition + separate :: [IText] -> IText separate by spaces + nest :: Int -> IText -> IText indent + pretty :: Int -> Int -> IText -> String format it + +* module QSort + Sort function using quicksort. + sortLe :: (a -> a -> Bool) -> [a] -> [a] sort le l sorts l with le as less than predicate + sort :: (Ord a) => [a] -> [a] sort l sorts l using the Ord class + +* module Random + Random numbers. + randomInts :: Int -> Int -> [Int] given two seeds gives a list of random Int + randomDoubles :: Int -> Int -> [Double] given two seeds gives a list of random Double + +* module RunDialogue + Test run programs of type Dialogue. + Only a few Requests are implemented, unfortunately not ReadChannel. + run :: Dialogue -> String just run the program, showing the output + runTrace :: Dialogue -> String run the program, showing each Request and Response + +* module Miranda + Functions found in the Miranda(tm) library. + +* module Printf + C printf style formatting. Handles same types as printf in C, but requires the arguments + to be tagged. Useful for formatting of floating point values. + data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double + printf :: String -> [UPrintf] -> String convert arguments in the list according to the formatting string + + +* module Time + Manipulate time values (a Double with seconds since 1970). + -- year mon day hour min sec dec-sec weekday + data Time = Time Int Int Int Int Int Int Double Int + dblToTime :: Double -> Time convert a Double to a Time + timeToDbl :: Time -> Double convert a Time to a Double + timeToString :: Time -> String convert a Time to a readable String + +----- To add: + +Bytes +IO Library +Word oprtations +Time clock stuff +Lisp stuff: symbols + hashtables + strings + + + + + + diff --git a/progs/lib/hbc/Random.hs b/progs/lib/hbc/Random.hs new file mode 100644 index 0000000..269d6af --- /dev/null +++ b/progs/lib/hbc/Random.hs @@ -0,0 +1,52 @@ +{- + This module implements a (good) random number generator. + + The June 1988 (v31 #6) issue of the Communications of the ACM has an + article by Pierre L'Ecuyer called, "Efficient and Portable Combined + Random Number Generators". Here is the Portable Combined Generator of + L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18. + + Transliterator: Lennart Augustsson +-} + +module Random(randomInts, randomDoubles) where +-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate +-- an infinite list of random Ints. +randomInts :: Int -> Int -> [Int] +randomInts s1 s2 = + if 1 <= s1 && s1 <= 2147483562 then + if 1 <= s2 && s2 <= 2147483398 then + rands s1 s2 + else + error "randomInts: Bad second seed." + else + error "randomInts: Bad first seed." + +rands :: Int -> Int -> [Int] +rands s1 s2 = + let + k = s1 `div` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `div` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + + z = s1'' - s2'' +{- + z' = if z < 1 then z + 2147483562 else z + + in z' : rands s1'' s2'' +-} +-- Use this instead; it is a little stricter and generates much better code + in if z < 1 then z + 2147483562 : rands s1'' s2'' + else z : rands s1'' s2'' + +-- For those of you who don't have fromInt +fromInt = fromInteger . toInteger + +-- Same values for s1 and s2 as above, generates an infinite +-- list of Doubles uniformly distibuted in (0,1). +randomDoubles :: Int -> Int -> [Double] +randomDoubles s1 s2 = map (\x -> fromInt x * 4.6566130638969828e-10) (randomInts s1 s2) diff --git a/progs/lib/hbc/Random.hu b/progs/lib/hbc/Random.hu new file mode 100644 index 0000000..9fff34e --- /dev/null +++ b/progs/lib/hbc/Random.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Random.hs diff --git a/progs/lib/hbc/Time.hs b/progs/lib/hbc/Time.hs new file mode 100644 index 0000000..29f3441 --- /dev/null +++ b/progs/lib/hbc/Time.hs @@ -0,0 +1,51 @@ +module Time(Time(..), dblToTime, timeToDbl, timeToString) where +-- year mon day hour min sec ... wday +data Time = Time Int Int Int Int Int Int Double Int deriving (Eq, Ord, Text) + +isleap :: Int -> Bool +isleap n = n `rem` 4 == 0 -- good enough for the UNIX time span + +daysin :: Int -> Int +daysin n = if isleap n then 366 else 365 + +monthlen :: Array (Bool, Int) Int +monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> (a,b):=c) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++ + zipWith3 (\ a b c -> (a,b):=c) (repeat True) [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]) + +-- Time zone offset in minutes +tzOffset = 120 -- Swedish DST + +dblToTime :: Double -> Time +dblToTime d = + let t = truncate d :: Int + offset = tzOffset -- timezone + (days, rem) = (t+offset*60) `quotRem` (60*60*24) + (hour, rem') = rem `quotRem` (60*60) + (min, sec) = rem' `quotRem` 60 + wday = (days+3) `mod` 7 + (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days) + (mon, day) = until (\ (m, d) -> d <= monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days') + in Time year mon (day+1) hour min sec (d - fromInt t) wday + +timeToDbl :: Time -> Double +timeToDbl (Time year mon day hour min sec sdec _) = + let year' = year - 1970 + offset = tzOffset -- timezone + days = year' * 365 + (year'+1) `div` 4 + + sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1 + secs = ((days*24 + hour) * 60 + min - offset) * 60 + sec + in fromInt secs + sdec + +show2 :: Int -> String +show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')] + +weekdays = ["Mon","Tue","Wen","Thu","Fri","Sat","Sun"] + +timeToString :: Time -> String +timeToString (Time year mon day hour min sec sdec wday) = + show year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++ + show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++ + tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday + +-- For those of you who don't have fromInt +fromInt = fromInteger . toInteger diff --git a/progs/lib/hbc/Time.hu b/progs/lib/hbc/Time.hu new file mode 100644 index 0000000..01c8f64 --- /dev/null +++ b/progs/lib/hbc/Time.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Time.hs diff --git a/progs/prelude/Prelude.hs b/progs/prelude/Prelude.hs new file mode 100644 index 0000000..bf20849 --- /dev/null +++ b/progs/prelude/Prelude.hs @@ -0,0 +1,187 @@ +-- Standard value bindings + +module Prelude ( + PreludeCore.., PreludeRatio.., PreludeComplex.., PreludeList.., + PreludeArray.., PreludeText.., PreludeIO.., + nullBin, isNullBin, appendBin, + (&&), (||), not, otherwise, + minChar, maxChar, ord, chr, + isAscii, isControl, isPrint, isSpace, + isUpper, isLower, isAlpha, isDigit, isAlphanum, + toUpper, toLower, + minInt, maxInt, subtract, gcd, lcm, (^), (^^), + fromIntegral, fromRealFrac, atan2, + fst, snd, id, const, (.), flip, ($), until, asTypeOf, error ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims + +import PreludeCore +import PreludeList +import PreludeArray +import PreludeRatio +import PreludeComplex +import PreludeText +import PreludeIO + +infixr 9 . +infixr 8 ^, ^^ +infixr 3 && +infixr 2 || +infixr 0 $ + + +-- Binary functions + +nullBin :: Bin +nullBin = primNullBin + +isNullBin :: Bin -> Bool +isNullBin = primIsNullBin + +appendBin :: Bin -> Bin -> Bin +appendBin = primAppendBin + +-- Boolean functions + +(&&), (||) :: Bool -> Bool -> Bool +True && x = x +False && _ = False +True || _ = True +False || x = x + +not :: Bool -> Bool +not True = False +not False = True + +{-# (&&) :: Inline #-} +{-# (||) :: Inline #-} +{-# not :: Inline #-} + + +otherwise :: Bool +otherwise = True + +-- Character functions + +minChar, maxChar :: Char +minChar = '\0' +maxChar = '\255' + +ord :: Char -> Int +ord = primCharToInt + +chr :: Int -> Char +chr = primIntToChar + +isAscii, isControl, isPrint, isSpace :: Char -> Bool +isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool + +isAscii c = ord c < 128 +isControl c = c < ' ' || c == '\DEL' +isPrint c = c >= ' ' && c <= '~' +isSpace c = c == ' ' || c == '\t' || c == '\n' || + c == '\r' || c == '\f' || c == '\v' +isUpper c = c >= 'A' && c <= 'Z' +isLower c = c >= 'a' && c <= 'z' +isAlpha c = isUpper c || isLower c +isDigit c = c >= '0' && c <= '9' +isAlphanum c = isAlpha c || isDigit c + + +toUpper, toLower :: Char -> Char +toUpper c | isLower c = chr ((ord c - ord 'a') + ord 'A') + | otherwise = c + +toLower c | isUpper c = chr ((ord c - ord 'A') + ord 'a') + | otherwise = c + +-- Numeric functions + +minInt, maxInt :: Int +minInt = primMinInt +maxInt = primMaxInt + +subtract :: (Num a) => a -> a -> a +subtract = flip (-) + +gcd :: (Integral a) => a -> a -> a +gcd 0 0 = error "gcd{Prelude}: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) + +lcm :: (Integral a) => a -> a -> a +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` (gcd x y)) * y) + +(^) :: (Num a, Integral b) => a -> b -> a +x ^ 0 = 1 +x ^ (n+1) = f x n x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n `quot` 2) + | otherwise = f x (n-1) (x*y) +_ ^ _ = error "(^){Prelude}: negative exponent" + +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x^n else recip (x^(-n)) + +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +fromRealFrac :: (RealFrac a, Fractional b) => a -> b +fromRealFrac = fromRational . toRational + +atan2 :: (RealFloat a) => a -> a -> a +atan2 y x = case (signum y, signum x) of + ( 0, 1) -> 0 + ( 1, 0) -> pi/2 + ( 0,-1) -> pi + (-1, 0) -> -pi/2 + ( _, 1) -> atan (y/x) + ( _,-1) -> atan (y/x) + pi + ( 0, 0) -> error "atan2{Prelude}: atan2 of origin" + + +-- Some standard functions: +-- component projections for pairs: +fst :: (a,b) -> a +fst (x,y) = x + +snd :: (a,b) -> b +snd (x,y) = y + +-- identity function +id :: a -> a +id x = x + +-- constant function +const :: a -> b -> a +const x _ = x + +-- function composition +(.) :: (b -> c) -> (a -> b) -> a -> c +f . g = \ x -> f (g x) + +-- flip f takes its (first) two arguments in the reverse order of f. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +-- right-associating infix application operator (useful in continuation- +-- passing style) +($) :: (a -> b) -> a -> b +f $ x = f x + +-- until p f yields the result of applying f until p holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x | p x = x + | otherwise = until p f (f x) + +-- asTypeOf is a type-restricted version of const. It is usually used +-- as an infix operator, and its typing forces its first argument +-- (which is usually overloaded) to have the same type as the second. +asTypeOf :: a -> a -> a +asTypeOf = const diff --git a/progs/prelude/Prelude.hu b/progs/prelude/Prelude.hu new file mode 100644 index 0000000..1ee32ca --- /dev/null +++ b/progs/prelude/Prelude.hu @@ -0,0 +1,16 @@ +:output $PRELUDEBIN/Prelude +:stable +:prelude +PreludePrims.hu +PreludeArrayPrims.hu +PreludeTuplePrims.hu +PreludeIOPrims.hu +Prelude.hs +PreludeArray.hs +PreludeComplex.hs +PreludeCore.hs +PreludeIO.hs +PreludeList.hs +PreludeRatio.hs +PreludeText.hs +PreludeTuple.hs diff --git a/progs/prelude/PreludeArray.hs b/progs/prelude/PreludeArray.hs new file mode 100644 index 0000000..a501631 --- /dev/null +++ b/progs/prelude/PreludeArray.hs @@ -0,0 +1,201 @@ +module PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds, + indices, elems, assocs, accumArray, (//), accum, amap, + ixmap + ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- This module uses some simple techniques with updatable vectors to +-- avoid vector copying in loops where single threading is obvious. +-- This is rather fragile and depends on the way the compiler handles +-- strictness. + +import PreludeBltinArray + +infixl 9 ! +infixl 9 // +infix 1 := + +data Assoc a b = a := b deriving (Eq, Ord, Ix, Text, Binary) +data (Ix a) => Array a b = MkArray (a,a) {-#STRICT#-} + (Vector (Box b)) {-#STRICT#-} + deriving () + +array :: (Ix a) => (a,a) -> [Assoc a b] -> Array a b +listArray :: (Ix a) => (a,a) -> [b] -> Array a b +(!) :: (Ix a) => Array a b -> a -> b +bounds :: (Ix a) => Array a b -> (a,a) +indices :: (Ix a) => Array a b -> [a] +elems :: (Ix a) => Array a b -> [b] +assocs :: (Ix a) => Array a b -> [Assoc a b] +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] + -> Array a b +(//) :: (Ix a) => Array a b -> [Assoc a b] -> Array a b +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c] + -> Array a b +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c + -> Array a c + +-- Arrays are a datatype containing a bounds pair and a vector of values. +-- Uninitialized array elements contain an error value. + +-- Primitive vectors now contain only unboxed values. This permits us to +-- treat array indexing as an atomic operation without forcing the element +-- being accessed. The boxing and unboxing of array elements happens +-- explicitly using these operations: + +data Box a = MkBox a +unBox (MkBox x) = x +{-# unBox :: Inline #-} + + +-- Array construction and update using index/value associations share +-- the same helper function. + +array b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayIvs b v ivs)) +{-# array :: Inline #-} + +a@(MkArray b v) // ivs = + let v' = primCopyVector v + in (MkArray b (updateArrayIvs b v' ivs)) +{-# (//) :: Inline #-} + +updateArrayIvs b v ivs = + let g (i := x) next = strict1 (primVectorUpdate v (index b i) (MkBox x)) + next + in foldr g v ivs +{-# updateArrayIvs :: Inline #-} + +uninitializedArrayError = + MkBox (error "(!){PreludeArray}: uninitialized array element.") + + +-- when mapping a list onto an array, be smart and don't do full index +-- computation + +listArray b@(bmin, bmax) vs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayVs size v vs)) +{-# listArray :: Inline #-} + +updateArrayVs size v vs = + let g x next j = if (j == size) + then v + else strict1 (primVectorUpdate v j (MkBox x)) + (next (j + 1)) + in foldr g (\ _ -> v) vs 0 +{-# updateArrayVs :: Inline #-} + + +-- Array access + +a@(MkArray b v) ! i = unBox (primVectorSel v (index b i)) +{-# (!) :: Inline #-} + +bounds (MkArray b _) = b + +indices = range . bounds + + +-- Again, when mapping array elements into a list, be smart and don't do +-- the full index computation for every element. + +elems a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let size = (index b bmax) + 1 + g j = if (j == size) + then n + else c (unBox (primVectorSel v j)) (g (j + 1)) + -- This strict1 is so size doesn't get inlined and recomputed + -- at every iteration. It should also force the array argument + -- to be strict. + in strict1 size (g 0)) +{-# elems :: Inline #-} + +assocs a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let g i next j = let y = unBox (primVectorSel v j) + in c (i := y) (next (j + 1)) + in foldr g (\ _ -> n) (range b) 0) +{-# assocs :: Inline #-} + + +-- accum and accumArray share the same helper function. The difference is +-- that accum makes a copy of an existing array and accumArray creates +-- a new one with all elements initialized to the given value. + +accum f a@(MkArray b v) ivs = + let v' = primCopyVector v + in (MkArray b (accumArrayIvs f b v' ivs)) +{-# accum :: Inline #-} + +accumArray f z b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size (MkBox z) + in (MkArray b (accumArrayIvs f b v ivs)) +{-# accumArray :: Inline #-} + + +-- This is a bit tricky. We need to force the access to the array element +-- before the update, but not force the thunk that is the value of the +-- array element unless f is strict. + +accumArrayIvs f b v ivs = + let g (i := x) next = + let j = index b i + y = primVectorSel v j + in strict1 + y + (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x))) + next) + in foldr g v ivs +{-# accumArrayIvs :: Inline #-} + + +-- again, be smart and bypass full array indexing on array mapping + +amap f a@(MkArray b@(bmin, bmax) v) = + let size = (index b bmax) + 1 + v' = primMakeVector size uninitializedArrayError + g j = if (j == size) + then v' + else let y = primVectorSel v j + in strict1 (primVectorUpdate v' j (MkBox (f (unBox y)))) + (g (j + 1)) + in (MkArray b (g 0)) +{-# amap :: Inline #-} + + +-- can't bypass the index computation here since f needs it as an argument + +ixmap b f a = array b [i := a ! f i | i <- range b] +{-# ixmap :: Inline #-} + + +-- random other stuff + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + +instance (Ix a, Text a, Text b) => Text (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ] + ++ + [(listArray b xs, u) | ("listArray",s) <- lex r, + (b,t) <- reads s, + (xs,u) <- reads t ]) diff --git a/progs/prelude/PreludeArrayPrims.hi b/progs/prelude/PreludeArrayPrims.hi new file mode 100644 index 0000000..a8529c0 --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hi @@ -0,0 +1,37 @@ +-- These primitives are used to implement arrays with constant time +-- access. There are destructive update routines for arrays for use +-- internally in functions such as array. These are impure but are +-- marked as pure to keep them out of the top level monad. This should +-- be redone using lambda-var someday. + +interface PreludeBltinArray where + + +data Vector a -- Used to represent vectors with delayed components +data Delay a -- An explicit represenation of a delayed object + + +-- Primitive vectors now always have strict components. This permits us +-- to treat array indexing as an atomic operation without the explicit +-- force on access. + +primVectorSel :: Vector a -> Int -> a +primVectorUpdate :: Vector a -> Int -> a -> a +primMakeVector :: Int -> a -> Vector a +primCopyVector :: Vector a -> Vector a + +-- These functions are used for explicit sequencing of destructive ops + +strict1 :: a -> b -> b +primForce :: Delay a -> a + +{-# +primVectorSel :: LispName("prim.vector-sel"), Complexity(1) +primVectorUpdate :: LispName("prim.vector-update"), Complexity(1) +primMakeVector :: LispName("prim.make-vector"), Complexity(4) +primCopyVector :: LispName("prim.copy-vector"), Complexity(5) +strict1 :: Strictness("S,N"), + LispName("prim.strict1") +primForce :: LispName("prim.force") +#-} + diff --git a/progs/prelude/PreludeArrayPrims.hu b/progs/prelude/PreludeArrayPrims.hu new file mode 100644 index 0000000..62ea8ac --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeArrayPrims +:stable +:prelude +PreludeArrayPrims.hi diff --git a/progs/prelude/PreludeComplex.hs b/progs/prelude/PreludeComplex.hs new file mode 100644 index 0000000..2044129 --- /dev/null +++ b/progs/prelude/PreludeComplex.hs @@ -0,0 +1,94 @@ +-- Complex Numbers + +module PreludeComplex where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 6 :+ + +data (RealFloat a) => Complex a = a {-#STRICT#-} :+ a {-#STRICT #-} + deriving (Eq,Binary,Text) + +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + +instance (RealFloat a) => Fractional (Complex a) where + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 + +instance (RealFloat a) => Floating (Complex a) where + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + sqrt 0 = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z@(x:+y) = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) + + +realPart, imagPart :: (RealFloat a) => Complex a -> a +realPart (x:+y) = x +imagPart (x:+y) = y + +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +magnitude, phase :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2)) + where k = max (exponent x) (exponent y) + mk = - k + +phase (x:+y) = atan2 y x diff --git a/progs/prelude/PreludeCore.hs b/progs/prelude/PreludeCore.hs new file mode 100644 index 0000000..f8a7be2 --- /dev/null +++ b/progs/prelude/PreludeCore.hs @@ -0,0 +1,817 @@ +-- Standard types, classes, and instances + +module PreludeCore ( + Eq((==), (/=)), + Ord((<), (<=), (>=), (>), max, min), + Num((+), (-), (*), negate, abs, signum, fromInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, + sin, cos, tan, asin, acos, atan, + sinh, cosh, tanh, asinh, acosh, atanh), + Real(toRational), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, + encodeFloat, decodeFloat, exponent, significand, scaleFloat), + Ix(range, index, inRange), + Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo), + Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..), + Binary(readBin, showBin), +-- List type: [_]((:), []) +-- Tuple types: (_,_), (_,_,_), etc. +-- Trivial type: () + Bool(True, False), + Char, Int, Integer, Float, Double, Bin, + Ratio, Complex((:+)), Assoc((:=)), Array, + String(..), Rational(..) ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims +import PreludeText +import PreludeRatio(Ratio, Rational(..)) +import PreludeComplex(Complex((:+))) +import PreludeArray(Assoc((:=)), Array) +import PreludeIO({-Request, Response,-} IOError, + Dialogue(..), SuccCont(..), StrCont(..), + StrListCont(..), BinCont(..), FailCont(..)) + +infixr 8 ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod` +infixl 6 +, - +infix 4 ==, /=, <, <=, >=, > + + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil deriving (Eq, Ord) +data Arrow a b = MkArrow a b +data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary) + +-- Equality and Ordered classes + +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +class (Eq a) => Ord a where + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + + x < y = x <= y && x /= y + x >= y = y <= x + x > y = y < x + + -- The following default methods are appropriate for partial orders. + -- Note that the second guards in each function can be replaced + -- by "otherwise" and the error cases, eliminated for total orders. + max x y | x >= y = x + | y >= x = y + |otherwise = error "max{PreludeCore}: no ordering relation" + min x y | x <= y = x + | y <= x = y + |otherwise = error "min{PreludeCore}: no ordering relation" + + +-- Numeric classes + +class (Eq a, Text a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + + x - y = x + negate y + +class (Num a, Enum a) => Real a where + toRational :: a -> Rational + +class (Real a, Ix a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + even, odd :: a -> Bool + toInteger :: a -> Integer + + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == - signum d then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + even n = n `rem` 2 == 0 + odd = not . even + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + + recip x = 1 / x + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + tanh x = sinh x / cosh x + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + + exponent x = if m == 0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + + significand x = encodeFloat m (- floatDigits x) + where (m,_) = decodeFloat x + + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + + +-- Index and Enumeration classes + +class (Ord a, Text a) => Ix a where -- This is a Yale modification + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + +class (Ord a) => Enum a where + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,n'..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + +defaultEnumFromTo n m = takeWhile (<= m) (enumFrom n) +defaultEnumFromThenTo n n' m + = takeWhile (if n' >= n then (<= m) else (>= m)) + (enumFromThen n n') +{-# defaultEnumFromTo :: Inline #-} +{-# defaultEnumFromThenTo :: Inline #-} + +-- Text class + +type ReadS a = String -> [(a,String)] +type ShowS = String -> String + +class Text a where + readsPrec :: Int -> ReadS a + showsPrec :: Int -> a -> ShowS + readList :: ReadS [a] + showList :: [a] -> ShowS + + readList = readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- reads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- reads t, + (xs,v) <- readl' u] + showList [] = showString "[]" + showList (x:xs) + = showChar '[' . shows x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . shows x . showl xs + + + +-- Binary class + +class Binary a where + readBin :: Bin -> (a,Bin) + showBin :: a -> Bin -> Bin + + +-- Trivial type + +-- data () = () deriving (Eq, Ord, Ix, Enum, Binary) + +instance Text () where + readsPrec p = readParen False + (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ] ) + showsPrec p () = showString "()" + + +-- Binary type + +instance Text Bin where + readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin." + showsPrec p b = showString "<<Bin>>" + + +-- Boolean type + +data Bool = False | True deriving (Eq, Ord, Ix, Enum, Text, Binary) + + +-- Character type + +instance Eq Char where + (==) = primEqChar + (/=) = primNeqChar + +instance Ord Char where + (<) = primLsChar + (<=) = primLeChar + (>) = primGtChar + (>=) = primGeChar + +instance Ix Char where + range (c,c') = [c..c'] + index b@(c,c') ci + | inRange b ci = ord ci - ord c + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (c,c') ci = ord c <= i && i <= ord c' + where i = ord ci + {-# range :: Inline #-} + +instance Enum Char where + enumFrom = charEnumFrom + enumFromThen = charEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +charEnumFrom c = map chr [ord c .. ord maxChar] +charEnumFromThen c c' = map chr [ord c, ord c' .. ord lastChar] + where lastChar = if c' < c then minChar else maxChar +{-# charEnumFrom :: Inline #-} +{-# charEnumFromThen :: Inline #-} + +instance Text Char where + readsPrec p = readParen False + (\r -> [(c,t) | ('\'':s,t)<- lex r, + (c,_) <- readLitChar s]) + + showsPrec p '\'' = showString "'\\''" + showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + + readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, + (l,_) <- readl s ]) + where readl ('"':s) = [("",s)] + readl ('\\':'&':s) = readl s + readl s = [(c:cs,u) | (c ,t) <- readLitChar s, + (cs,u) <- readl t ] + + showList cs = showChar '"' . showl cs + where showl "" = showChar '"' + showl ('"':cs) = showString "\\\"" . showl cs + showl (c:cs) = showLitChar c . showl cs + +type String = [Char] + + +-- Standard Integral types + +instance Eq Int where + (==) = primEqInt + (/=) = primNeqInt + +instance Eq Integer where + (==) = primEqInteger + (/=) = primNeqInteger + +instance Ord Int where + (<) = primLsInt + (<=) = primLeInt + (>) = primGtInt + (>=) = primGeInt + max = primIntMax + min = primIntMin + +instance Ord Integer where + (<) = primLsInteger + (<=) = primLeInteger + (>) = primGtInteger + (>=) = primGeInteger + max = primIntegerMax + min = primIntegerMin + +instance Num Int where + (+) = primPlusInt + (-) = primMinusInt + negate = primNegInt + (*) = primMulInt + abs = primAbsInt + signum = signumReal + fromInteger = primIntegerToInt + +instance Num Integer where + (+) = primPlusInteger + (-) = primMinusInteger + negate = primNegInteger + (*) = primMulInteger + abs = primAbsInteger + signum = signumReal + fromInteger x = x + +signumReal x | x == 0 = 0 + | x > 0 = 1 + | otherwise = -1 + +instance Real Int where + toRational x = toInteger x % 1 + +instance Real Integer where + toRational x = x % 1 + +instance Integral Int where + quotRem = primQuotRemInt + toInteger = primIntToInteger + +instance Integral Integer where + quotRem = primQuotRemInteger + toInteger x = x + +instance Ix Int where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = i - m + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (m,n) i = m <= i && i <= n + {-# range :: Inline #-} + +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (m,n) i = m <= i && i <= n + {-# range :: Inline #-} + +instance Enum Int where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Integer where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +numericEnumFrom :: (Real a) => a -> [a] +numericEnumFromThen :: (Real a) => a -> a -> [a] +numericEnumFrom = iterate (+1) +numericEnumFromThen n m = iterate (+(m-n)) n + +{-# numericEnumFrom :: Inline #-} +{-# numericEnumFromThen :: Inline #-} + + +instance Text Int where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + +instance Text Integer where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + + +-- Standard Floating types + +instance Eq Float where + (==) = primEqFloat + (/=) = primNeqFloat + +instance Eq Double where + (==) = primEqDouble + (/=) = primNeqDouble + +instance Ord Float where + (<) = primLsFloat + (<=) = primLeFloat + (>) = primGtFloat + (>=) = primGeFloat + max = primFloatMax + min = primFloatMin + +instance Ord Double where + (<) = primLsDouble + (<=) = primLeDouble + (>) = primGtDouble + (>=) = primGeDouble + max = primDoubleMax + min = primDoubleMax + +instance Num Float where + (+) = primPlusFloat + (-) = primMinusFloat + negate = primNegFloat + (*) = primMulFloat + abs = primAbsFloat + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Num Double where + (+) = primPlusDouble + (-) = primMinusDouble + negate = primNegDouble + (*) = primMulDouble + abs = primAbsDouble + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Real Float where + toRational = primFloatToRational + +instance Real Double where + toRational = primDoubleToRational + +-- realFloatToRational x = (m%1)*(b%1)^^n +-- where (m,n) = decodeFloat x +-- b = floatRadix x + +instance Fractional Float where + (/) = primDivFloat + fromRational = primRationalToFloat +-- fromRational = rationalToRealFloat + +instance Fractional Double where + (/) = primDivDouble + fromRational = primRationalToDouble +-- fromRational = rationalToRealFloat + +-- rationalToRealFloat x = x' +-- where x' = f e +-- f e = if e' == e then y else f e' +-- where y = encodeFloat (round (x * (1%b)^^e)) e +-- (_,e') = decodeFloat y +-- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' +-- / fromInteger (denominator x)) +-- b = floatRadix x' + +instance Floating Float where + pi = primPiFloat + exp = primExpFloat + log = primLogFloat + sqrt = primSqrtFloat + sin = primSinFloat + cos = primCosFloat + tan = primTanFloat + asin = primAsinFloat + acos = primAcosFloat + atan = primAtanFloat + sinh = primSinhFloat + cosh = primCoshFloat + tanh = primTanhFloat + asinh = primAsinhFloat + acosh = primAcoshFloat + atanh = primAtanhFloat + +instance Floating Double where + pi = primPiDouble + exp = primExpDouble + log = primLogDouble + sqrt = primSqrtDouble + sin = primSinDouble + cos = primCosDouble + tan = primTanDouble + asin = primAsinDouble + acos = primAcosDouble + atan = primAtanDouble + sinh = primSinhDouble + cosh = primCoshDouble + tanh = primTanhDouble + asinh = primAsinhDouble + acosh = primAcoshDouble + atanh = primAtanhDouble + + +instance RealFrac Float where + properFraction = floatProperFraction + +instance RealFrac Double where + properFraction = floatProperFraction + +floatProperFraction x + | n >= 0 = (fromInteger m * fromInteger b ^ n, 0) + | otherwise = (fromInteger w, encodeFloat r n) + where (m,n) = decodeFloat x + b = floatRadix x + (w,r) = quotRem m (b^(-n)) + +instance RealFloat Float where + floatRadix _ = primFloatRadix + floatDigits _ = primFloatDigits + floatRange _ = (primFloatMinExp,primFloatMaxExp) + decodeFloat = primDecodeFloat + encodeFloat = primEncodeFloat + +instance RealFloat Double where + floatRadix _ = primDoubleRadix + floatDigits _ = primDoubleDigits + floatRange _ = (primDoubleMinExp,primDoubleMaxExp) + decodeFloat = primDecodeDouble + encodeFloat = primEncodeDouble + +instance Enum Float where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Double where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Text Float where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + +instance Text Double where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + + +-- Lists + +-- data [a] = [] | a : [a] deriving (Eq, Ord, Binary) + +instance (Text a) => Text [a] where + readsPrec p = readList + showsPrec p = showList + + +-- Tuples + +-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Binary) +{- +instance (Text a, Text b) => Text (a,b) where + readsPrec p = readParen False + (\r -> [((x,y), w) | ("(",s) <- lex r, + (x,t) <- reads s, + (",",u) <- lex t, + (y,v) <- reads u, + (")",w) <- lex v ] ) + + showsPrec p (x,y) = showChar '(' . shows x . showChar ',' . + shows y . showChar ')' +-- et cetera +-} + +-- Functions + +instance Text (a -> b) where + readsPrec p s = error "readsPrec{PreludeCore}: Cannot read functions." + showsPrec p f = showString "<<function>>" + +-- Support for class Bin + +instance Binary Int where + showBin i b = primShowBinInt i b + readBin b = primReadBinInt b + +instance Binary Integer where + showBin i b = primShowBinInteger i b + readBin b = primReadBinInteger b + +instance Binary Float where + showBin f b = primShowBinFloat f b + readBin b = primReadBinFloat b + +instance Binary Double where + showBin d b = primShowBinDouble d b + readBin b = primReadBinDouble b + +instance Binary Char where + showBin c b = primShowBinInt (ord c) b + readBin b = (chr i,b') where + (i,b') = primReadBinSmallInt b primMaxChar + +instance (Binary a) => Binary [a] where + showBin l b = showBin (length l :: Int) (sb1 l b) where + sb1 [] b = b + sb1 (h:t) b = showBin h (sb1 t b) + readBin bin = rbl len bin' where + len :: Int + (len,bin') = readBin bin + rbl 0 b = ([],b) + rbl n b = (h:t,b'') where + (h,b') = readBin b + (t,b'') = rbl (n-1) b' + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + showBin a = showBin (bounds a) . showBin (elems a) + readBin bin = (listArray b vs, bin'') + where (b,bin') = readBin bin + (vs,bin'') = readBin bin' + +{- +instance (Binary a, Binary b) => Binary (a,b) where + showBin (x,y) = (showBin x) . (showBin y) + readBin b = ((x,y),b'') where + (x,b') = readBin b + (y,b'') = readBin b' + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + showBin (x,y,z) = (showBin x) . (showBin y) . (showBin z) + readBin b = ((x,y,z),b3) where + (x,b1) = readBin b + (y,b2) = readBin b1 + (z,b3) = readBin b2 + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + showBin (a,b,c,d) = (showBin a) . (showBin b) . (showBin c) . (showBin d) + readBin b = ((a1,a2,a3,a4),b4) where + (a1,b1) = readBin b + (a2,b2) = readBin b1 + (a3,b3) = readBin b2 + (a4,b4) = readBin b3 +-} +-- Instances for tuples + +-- This whole section should be handled in the support code. For now, +-- only tuple instances expliticly provided here are available. +-- Currently provided: + +-- 2,3 tuples: all classes (Eq, Ord, Ix, Bin, Text) +-- 4 tuples: Eq, Bin, Text +-- 5, 6 tuples: Text (printing only) + +{- +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +instance (Eq a1, Eq a2) => Eq (a1,a2) where + (a1,a2) == (z1,z2) = a1==z1 && a2==z2 + +instance (Ord a1, Ord a2) => Ord (a1,a2) where + (a1,a2) <= (z1,z2) = a1<=z1 || a1==z1 && a2<=z2 + (a1,a2) < (z1,z2) = a1<z1 || a1==z1 && a2<z2 + +instance (Ix a1, Ix a2) => Ix (a1,a2) where + range ((l1,l2),(u1,u2)) = [(i1,i2) | i1 <- range(l1,u1), + i2 <- range(l2,u2)] + index ((l1,l2),(u1,u2)) (i1,i2) = + index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + +{- Apprears in Joe's code. +instance (Text a1, Text a2) => Text (a1,a2) where + readsPrec p = readParen False + (\r0 -> [((a1,a2), w) | ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (")",w) <- lex r4 ]) + + showsPrec p (a1,a2) = showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ')' +-} + +instance (Eq a1, Eq a2, Eq a3) => Eq (a1,a2,a3) where + (a1,a2,a3) == (z1,z2,z3) = a1==z1 && a2==z2 && a3==z3 + +instance (Ord a1, Ord a2, Ord a3) => Ord (a1,a2,a3) where + (a1,a2,a3) <= (z1,z2,z3) = a1<=z1 || a1==z1 && + (a2<=z2 || a2==z2 && + a3<=z3) + (a1,a2,a3) < (z1,z2,z3) = a1<z1 || a1==z1 && + (a2<z2 || a2==z2 && + a3<z3) + + +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range(l1,u1), + i2 <- range(l2,u2), + i3 <- range(l3,u3)] + index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + (index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 ) * rangeSize (l3,u3) + + index (l3,u3) i3 + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 + + +instance (Text a1, Text a2, Text a3) => Text (a1,a2,a3) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (")",w) <- lex r6 ]) + showsPrec p (a1,a2,a3) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ')' + +instance (Eq a1, Eq a2, Eq a3, Eq a4) => Eq (a1,a2,a3,a4) where + (a1,a2,a3,a4) == (z1,z2,z3,z4) = a1==z1 && a2==z2 && a3==z3 && a4 == z4 + +instance (Text a1, Text a2, Text a3, Text a4) => Text (a1,a2,a3,a4) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3,a4), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (",",r7) <- lex r6, + (a4,r8) <- reads r7, + (")",w) <- lex r8 ]) + showsPrec p (a1,a2,a3,a4) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5) => + Text (a1,a2,a3,a4,a5) where + readsPrec p = error "Read of 5 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5, Text a6) => + Text (a1,a2,a3,a4,a5,a6) where + readsPrec p = error "Read of 6 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5,a6) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ',' . + shows a6 . showChar ')' + + +-} diff --git a/progs/prelude/PreludeIO.hs b/progs/prelude/PreludeIO.hs new file mode 100644 index 0000000..6173d8c --- /dev/null +++ b/progs/prelude/PreludeIO.hs @@ -0,0 +1,232 @@ +-- I/O functions and definitions + +module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-} + IOError(..),Dialogue(..),IO(..),SystemState,IOResult, + SuccCont(..),StrCont(..), + StrListCont(..),BinCont(..),FailCont(..), + readFile, writeFile, appendFile, readBinFile, + writeBinFile, appendBinFile, deleteFile, statusFile, + readChan, appendChan, readBinChan, appendBinChan, + statusChan, echo, getArgs, getProgName, getEnv, setEnv, + done, exit, abort, print, prints, interact, + thenIO,thenIO_,seqIO,returnIO, doneIO) + where + +import PreludeBltinIO +import PreludeBltinArray(strict1) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- These datatypes are used by the monad. + +type IO a = SystemState -> IOResult a + +data SystemState = SystemState +data IOResult a = IOResult a + +-- Operations in the monad + +-- This definition is needed to allow proper tail recursion of the Lisp +-- code. The use of strict1 forces f1 s (since getState is strict) before +-- the call to f2. The optimizer removed getState and getRes from the +-- generated code. + +{-# thenIO :: Inline #-} +thenIO f1 f2 s = + let g = f1 s + s' = getState g in + strict1 s' (f2 (getRes g) s') + +{-# thenIO_ :: Inline #-} +x `thenIO_` y = x `thenIO` \_ -> y +x `seqIO` y = x `thenIO` \_ -> y + +-- The returnIO function is implemented directly as a primitive. +doneIO = returnIO () + + +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" + + +-- Requests and responses: + +{- Not used since streams are no longer supported: +data Request = -- file system requests: + ReadFile String + | WriteFile String String + | AppendFile String String + | ReadBinFile String + | WriteBinFile String Bin + | AppendBinFile String Bin + | DeleteFile String + | StatusFile String + -- channel system requests: + | ReadChan String + | AppendChan String String + | ReadBinChan String + | AppendBinChan String Bin + | StatusChan String + -- environment requests: + | Echo Bool + | GetArgs + | GetProgName + | GetEnv String + | SetEnv String String + deriving Text + +data Response = Success + | Str String + | StrList [String] + | Bn Bin + | Failure IOError + deriving Text + +-} + +data IOError = WriteError String + | ReadError String + | SearchError String + | FormatError String + | OtherError String + deriving Text + +-- Continuation-based I/O: + +type Dialogue = IO () +type SuccCont = Dialogue +type StrCont = String -> Dialogue +type StrListCont = [String] -> Dialogue +type BinCont = Bin -> Dialogue +type FailCont = IOError -> Dialogue + +done :: Dialogue +readFile :: String -> FailCont -> StrCont -> Dialogue +writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue +appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinFile :: String -> FailCont -> BinCont -> Dialogue +writeBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +deleteFile :: String -> FailCont -> SuccCont -> Dialogue +statusFile :: String -> FailCont -> StrCont -> Dialogue +readChan :: String -> FailCont -> StrCont -> Dialogue +appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinChan :: String -> FailCont -> BinCont -> Dialogue +appendBinChan :: String -> Bin -> FailCont -> SuccCont -> Dialogue +statusChan :: String -> FailCont -> StrCont -> Dialogue +echo :: Bool -> FailCont -> SuccCont -> Dialogue +getArgs :: FailCont -> StrListCont -> Dialogue +getProgName :: FailCont -> StrCont -> Dialogue +getEnv :: String -> FailCont -> StrCont -> Dialogue +setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue + +done = returnIO () + +readFile name fail succ = + primReadStringFile name `thenIO` objDispatch fail succ + +writeFile name contents fail succ = + primWriteStringFile name contents `thenIO` succDispatch fail succ + +appendFile name contents fail succ = + primAppendStringFile name contents `thenIO` succDispatch fail succ + +readBinFile name fail succ = + primReadBinFile name `thenIO` objDispatch fail succ + +writeBinFile name contents fail succ = + primWriteBinFile name contents `thenIO` succDispatch fail succ + +appendBinFile name contents fail succ = + primAppendBinFile name contents `thenIO` succDispatch fail succ + +deleteFile name fail succ = + primDeleteFile name `thenIO` succDispatch fail succ + +statusFile name fail succ = + primStatusFile name `thenIO` + (\status -> case status of Succ s -> succ s + Fail msg -> fail (SearchError msg)) + +readChan name fail succ = + if name == stdin then + primReadStdin `thenIO` succ + else + badChan fail name + +appendChan name contents fail succ = + if name == stdout then + primWriteStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +readBinChan name fail succ = + if name == stdin then + primReadBinStdin `thenIO` objDispatch fail succ + else + badChan fail name + +appendBinChan name contents fail succ = + if name == stdout then + primWriteBinStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +statusChan name fail succ = + if name == stdin || name == stdout then + succ "0 0" + else + fail (SearchError "Channel not defined") + +echo bool fail succ = + if bool then + succ + else + fail (OtherError "Echo cannot be turned off") + +getArgs fail succ = + succ [""] + +getProgName fail succ = + succ "haskell" + +getEnv name fail succ = + primGetEnv name `thenIO` objDispatch fail succ + +setEnv name val fail succ = + fail (OtherError "setEnv not implemented") + +objDispatch fail succ r = + case r of Succ s -> succ s + Fail msg -> fail (OtherError msg) + +succDispatch fail succ r = + case r of Succ _ -> succ + Fail msg -> fail (OtherError msg) + +badChan f name = f (OtherError ("Improper IO Channel: " ++ name)) + +abort :: FailCont +abort err = done + +exit :: FailCont +exit err = appendChan stderr (msg ++ "\n") abort done + where msg = case err of ReadError s -> s + WriteError s -> s + SearchError s -> s + FormatError s -> s + OtherError s -> s + +print :: (Text a) => a -> Dialogue +print x = appendChan stdout (show x) exit done +prints :: (Text a) => a -> String -> Dialogue +prints x s = appendChan stdout (shows x s) exit done + +interact :: (String -> String) -> Dialogue +interact f = readChan stdin exit + (\x -> appendChan stdout (f x) exit done) + diff --git a/progs/prelude/PreludeIOMonad.hs b/progs/prelude/PreludeIOMonad.hs new file mode 100644 index 0000000..9a45606 --- /dev/null +++ b/progs/prelude/PreludeIOMonad.hs @@ -0,0 +1,60 @@ +module IOMonad (State, IO(..)) where + +import IOMonadPrims + +{- I use data instead of type so that IO can be abstract. For efficiency, + IO can be annotated as a strict constructor. +-} + +type IO a = State -> (State, a) + +data State = State + +-- The rest of this file is unnecessary at the moment since +-- unitIO & bindIO are primitives and we're not using the rest of this + +{- Implemented as a primitives: +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) (IO k) = IO (\s0 -> let (s1, a) = m s0 in k a s1) -} + +unitIO :: a -> IO a +unitIO x = IO (\s -> (s, x)) + +-} + +{- Not currently used: +pureIO :: IO a -> a +pureIO (IO m) = let (s, x) = m State in x + +-- execIO executes a program of type IO (). +execIO :: IO () -> State +execIO (IO m) = let (s, x) = m State in s + +infixr 1 =: +infixr 1 ? + +-- assignment +(=:) :: a -> Var a -> IO () +x =: v = IO (\s -> (update v x s, ())) + +-- reader +(?) :: Var a -> (a -> IO b) -> IO b +v ? k = IO (\s -> (s, readVar v s)) `bindIO` k + +-- new +newvar :: IO (Var a) +newvar = IO allocVar + +instance Eq (Var a) where + x == y = eqVar x y +-} + + + + + + + + + + diff --git a/progs/prelude/PreludeIOPrims.hi b/progs/prelude/PreludeIOPrims.hi new file mode 100644 index 0000000..e4c2e74 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hi @@ -0,0 +1,55 @@ +-- These lisp functions implement the standard Haskell requests + +interface PreludeBltinIO where + +import PreludeCore(String,Bin) +import PreludeIO(SystemState,IOResult,IO) +data IOResponse a = Succ a | Fail String + +{-# Prelude #-} + +primReadStringFile :: String -> IO (IOResponse String) +primWriteStringFile :: String -> String -> IO (IOResponse ()) +primAppendStringFile :: String -> String -> IO (IOResponse ()) +primReadBinFile :: String -> IO (IOResponse Bin) +primWriteBinFile :: String -> Bin -> IO (IOResponse ()) +primAppendBinFile :: String -> Bin -> IO (IOResponse ()) +primDeleteFile :: String -> IO (IOResponse ()) +primStatusFile :: String -> IO (IOResponse String) +primReadStdin :: IO String +primWriteStdout :: String -> IO (IOResponse ()) +primReadBinStdin :: IO (IOResponse Bin) +primWriteBinStdout :: Bin -> IO (IOResponse ()) +primGetEnv :: String -> IO (IOResponse String) + +{-# +primReadStringFile :: LispName("prim.read-string-file") +primWriteStringFile :: LispName("prim.write-string-file"), NoConversion +primAppendStringFile :: LispName("prim.append-string-file"), NoConversion +primReadBinFile :: LispName("prim.read-bin-file") +primWriteBinFile :: LispName("prim.write-bin-file") +primAppendBinFile :: LispName("prim.append-bin-file") +primDeleteFile :: LispName("prim.delete-file") +primStatusFile :: LispName("prim.status-file") +primReadStdin :: LispName("prim.read-string-stdin"), NoConversion +primWriteStdout :: LispName("prim.write-string-stdout"), NoConversion +primReadBinStdin :: LispName("prim.read-bin-stdin") +primWriteBinStdout :: LispName("prim.write-bin-stdout") +primGetEnv :: LispName("prim.getenv") +#-} + +-- Monad prims + +returnIO :: a -> IO a +getState :: IOResult a -> SystemState +getRes :: IOResult a -> a + +{-# +returnIO :: LispName("prim.returnio"), + Strictness("N,S"), NoConversion, Complexity(3) +getState :: LispName("prim.getstate"), + Strictness("S"), NoConversion, Complexity(3) +getRes :: LispName("prim.getres"), + Strictness("S"), NoConversion +#-} + diff --git a/progs/prelude/PreludeIOPrims.hu b/progs/prelude/PreludeIOPrims.hu new file mode 100644 index 0000000..66393c5 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeIOPrims +:stable +:prelude +PreludeIOPrims.hi diff --git a/progs/prelude/PreludeList.hs b/progs/prelude/PreludeList.hs new file mode 100644 index 0000000..3e445c3 --- /dev/null +++ b/progs/prelude/PreludeList.hs @@ -0,0 +1,585 @@ +-- Standard list functions + +-- build really shouldn't be exported, but what the heck. +-- some of the helper functions in this file shouldn't be +-- exported either! + +module PreludeList (PreludeList.., foldr, build) where + +import PreludePrims(build, foldr) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 9 !! +infix 5 \\ +infixr 5 ++ +infix 4 `elem`, `notElem` + + +-- These are primitives used by the deforestation stuff in the optimizer. +-- the optimizer will turn references to foldr and build into +-- inlineFoldr and inlineBuild, respectively, but doesn't want to +-- necessarily inline all references immediately. + +inlineFoldr :: (a -> b -> b) -> b -> [a] -> b +inlineFoldr f z l = + let foldr' [] = z + foldr' (x:xs) = f x (foldr' xs) + in foldr' l +{-# inlineFoldr :: Inline #-} + + +inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] +inlineBuild g = g (:) [] +{-# inlineBuild :: Inline #-} + + +-- head and tail extract the first element and remaining elements, +-- respectively, of a list, which must be non-empty. last and init +-- are the dual functions working from the end of a finite list, +-- rather than the beginning. + +head :: [a] -> a +head (x:_) = x +head [] = error "head{PreludeList}: head []" + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs +last [] = error "last{PreludeList}: last []" + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "tail{PreludeList}: tail []" + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs +init [] = error "init{PreludeList}: init []" + +-- null determines if a list is empty. +null :: [a] -> Bool +null [] = True +null (_:_) = False + + +-- list concatenation (right-associative) + +(++) :: [a] -> [a] -> [a] +xs ++ ys = build (\ c n -> foldr c (foldr c n ys) xs) +{-# (++) :: Inline #-} + + +-- the first occurrence of each element of ys in turn (if any) +-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl del + where [] `del` _ = [] + (x:xs) `del` y + | x == y = xs + | otherwise = x : xs `del` y + +-- length returns the length of a finite list as an Int; it is an instance +-- of the more general genericLength, the result type of which may be +-- any kind of number. + +genericLength :: (Num a) => [b] -> a +genericLength l = foldr (\ x n -> 1 + n) 0 l +--genericLength [] = 0 +--genericLength (x:xs) = 1 + genericLength xs +{-# genericLength :: Inline #-} + + +length :: [a] -> Int +length l = foldr (\ x n -> 1 + n) 0 l +--length [] = 0 +--length (x:xs) = 1 + length xs +{-# length :: Inline #-} + +-- List index (subscript) operator, 0-origin +(!!) :: (Integral a) => [b] -> a -> b +l !! i = nth l (fromIntegral i) +{-# (!!) :: Inline #-} + +nth :: [b] -> Int -> b +nth l m = let f x g 0 = x + f x g i = g (i - 1) + fail _ = error "(!!){PreludeList}: index too large" + in foldr f fail l m +{-# nth :: Inline #-} +--nth _ n | n < 0 = error "(!!){PreludeList}: negative index" +--nth [] n = error "(!!){PreludeList}: index too large" +--nth (x:xs) n +-- | n == 0 = x +-- | otherwise = nth xs (n - 1) +--{-# nth :: Strictness("S,S") #-} + +-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs]. +map :: (a -> b) -> [a] -> [b] +map f xs = build (\ c n -> foldr (\ a b -> c (f a) b) n xs) +--map f [] = [] +--map f (x:xs) = f x : map f xs +{-# map :: Inline #-} + + +-- filter, applied to a predicate and a list, returns the list of those +-- elements that satisfy the predicate; i.e., +-- filter p xs == [x | x <- xs, p x]. +filter :: (a -> Bool) -> [a] -> [a] +filter f xs = build (\ c n -> + foldr (\ a b -> if f a then c a b else b) + n xs) +--filter p = foldr (\x xs -> if p x then x:xs else xs) [] +{-# filter :: Inline #-} + + +-- partition takes a predicate and a list and returns a pair of lists: +-- those elements of the argument list that do and do not satisfy the +-- predicate, respectively; i.e., +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p = foldr select ([],[]) + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts,x:fs) +{-# partition :: Inline #-} + + +-- foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a list, reduces the list using +-- the binary operator, from left to right: +-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- foldl1 is a variant that has no starting value argument, and thus must +-- be applied to non-empty lists. scanl is similar to foldl, but returns +-- a list of successive reduced values from the left: +-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- Note that last (scanl f z xs) == foldl f z xs. +-- scanl1 is similar, again without the starting element: +-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z xs = foldr (\ b g a -> g (f a b)) id xs z +--foldl f z [] = z +--foldl f z (x:xs) = foldl f (f z x) xs +{-# foldl :: Inline #-} + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs +foldl1 _ [] = error "foldl1{PreludeList}: empty list" +{-# foldl1 :: Inline #-} + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) +{-# scanl :: Inline #-} + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = error "scanl1{PreludeList}: empty list" +{-# scanl1 :: Inline #-} + + +-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the +-- above functions. + +--foldr :: (a -> b -> b) -> b -> [a] -> b +--foldr f z [] = z +--foldr f z (x:xs) = f x (foldr f z xs) + + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) +foldr1 _ [] = error "foldr1{PreludeList}: empty list" +{-# foldr1 :: Inline #-} + + +-- I'm not sure the build/foldr expansion wins. + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +--scanr f q0 l = build (\ c n -> +-- let g x qs@(q:_) = c (f x q) qs +-- in foldr g (c q0 n) l) +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs +{-# scanr :: Inline #-} + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs +scanr1 _ [] = error "scanr1{PreludeList}: empty list" +{-# scanr1 :: Inline #-} + + +-- iterate f x returns an infinite list of repeated applications of f to x: +-- iterate f x == [x, f x, f (f x), ...] +iterate :: (a -> a) -> a -> [a] +iterate f x = build (\ c n -> + let iterate' x' = c x' (iterate' (f x')) + in iterate' x) +--iterate f x = x : iterate f (f x) +{-# iterate :: Inline #-} + + +-- repeat x is an infinite list, with x the value of every element. +repeat :: a -> [a] +repeat x = build (\ c n -> let r = c x r in r) +--repeat x = xs where xs = x:xs +{-# repeat :: Inline #-} + +-- cycle ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. + +cycle :: [a] -> [a] +cycle xs = xs' where xs' = xs ++ xs' + + +-- take n, applied to a list xs, returns the prefix of xs of length n, +-- or xs itself if n > length xs. drop n xs returns the suffix of xs +-- after the first n elements, or [] if n > length xs. splitAt n xs +-- is equivalent to (take n xs, drop n xs). + +take :: (Integral a) => a -> [b] -> [b] +take n l = takeInt (fromIntegral n) l +{-# take :: Inline #-} + +takeInt :: Int -> [b] -> [b] +takeInt m l = + build (\ c n -> + let f x g i | i <= 0 = n + | otherwise = c x (g (i - 1)) + in foldr f (\ _ -> n) l m) +--takeInt 0 _ = [] +--takeInt _ [] = [] +--takeInt n l | n > 0 = primTake n l +{-# takeInt :: Inline #-} + + + +-- Writing drop and friends in terms of build/foldr seems to lose +-- way big since they cause an extra traversal of the list tail +-- (except when the calls are being deforested). + +drop :: (Integral a) => a -> [b] -> [b] +drop n l = dropInt (fromIntegral n) l +{-# drop :: Inline #-} +{-# drop :: Strictness("S,S") #-} + + +dropInt :: Int -> [b] -> [b] +dropInt 0 xs = xs +dropInt _ [] = [] +dropInt (n+1) (_:xs) = dropInt n xs +{-# dropInt :: Inline #-} + +splitAt :: (Integral a) => a -> [b] -> ([b],[b]) +splitAt n l = splitAtInt (fromIntegral n) l +{-# splitAt :: Inline #-} + +splitAtInt :: Int -> [b] -> ([b],[b]) +splitAtInt 0 xs = ([],xs) +splitAtInt _ [] = ([],[]) +splitAtInt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAtInt n xs +{-# splitAtInt :: Inline #-} + +-- takeWhile, applied to a predicate p and a list xs, returns the longest +-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs +-- returns the remaining suffix. Span p xs is equivalent to +-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l) +--takeWhile p [] = [] +--takeWhile p (x:xs) +-- | p x = x : takeWhile p xs +-- | otherwise = [] +{-# takeWhile :: Inline #-} + + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs +{-# dropWhile :: Inline #-} + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = let (ys,zs) = span p xs' in (x:ys,zs) + | otherwise = ([],xs) +break p = span (not . p) + +{-# span :: Inline #-} +{-# break :: Inline #-} + + +-- lines breaks a string up into a list of strings at newline characters. +-- The resulting strings do not contain newlines. Similary, words +-- breaks a string up into a list of words, which were delimited by +-- white space. unlines and unwords are the inverse operations. +-- unlines joins lines with terminating newlines, and unwords joins +-- words with separating spaces. + +lines :: String -> [String] +lines "" = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' + +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break isSpace s' + +unlines :: [String] -> String +unlines = concat . map (++ "\n") +{-# unlines :: Inline #-} + + +unwords :: [String] -> String +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +-- nub (meaning "essence") removes duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +nub l = build (\ c n -> + let f x g [] = c x (g [x]) + f x g xs = if elem x xs + then (g xs) + else c x (g (x:xs)) + in foldr f (\ _ -> n) l []) +{-# nub :: Inline #-} +--nub [] = [] +--nub (x:xs) = x : nub (filter (/= x) xs) + +-- reverse xs returns the elements of xs in reverse order. xs must be finite. +reverse :: [a] -> [a] +reverse l = build (\ c n -> + let f x g tail = g (c x tail) + in foldr f id l n) +{-# reverse :: Inline #-} +--reverse x = reverse1 x [] where +-- reverse1 [] a = a +-- reverse1 (x:xs) a = reverse1 xs (x:a) + +-- and returns the conjunction of a Boolean list. For the result to be +-- True, the list must be finite; False, however, results from a False +-- value at a finite index of a finite or infinite list. or is the +-- disjunctive dual of and. +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False +{-# and :: Inline #-} +{-# or :: Inline #-} + +-- Applied to a predicate and a list, any determines if any element +-- of the list satisfies the predicate. Similarly, for all. +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p +{-# any :: Inline #-} +{-# all :: Inline #-} + +-- elem is the list membership predicate, usually written in infix form, +-- e.g., x `elem` xs. notElem is the negation. +elem, notElem :: (Eq a) => a -> [a] -> Bool + +elem x ys = foldr (\ y t -> (x == y) || t) False ys +--x `elem` [] = False +--x `elem` (y:ys) = x == y || x `elem` ys +{-# elem :: Inline #-} +notElem x y = not (x `elem` y) + +-- sum and product compute the sum or product of a finite list of numbers. +sum, product :: (Num a) => [a] -> a +sum = foldl (+) 0 +product = foldl (*) 1 +{-# sum :: Inline #-} +{-# product :: Inline #-} + +-- sums and products give a list of running sums or products from +-- a list of numbers. For example, sums [1,2,3] == [0,1,3,6]. +sums, products :: (Num a) => [a] -> [a] +sums = scanl (+) 0 +products = scanl (*) 1 + +-- maximum and minimum return the maximum or minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +maximum, minimum :: (Ord a) => [a] -> a +maximum = foldl1 max +minimum = foldl1 min +{-# maximum :: Inline #-} +{-# minimum :: Inline #-} + +-- concat, applied to a list of lists, returns their flattened concatenation. +concat :: [[a]] -> [a] +concat xs = build (\ c n -> foldr (\ x y -> foldr c y x) n xs) +--concat [] = [] +--concat (l:ls) = l ++ concat ls +{-# concat :: Inline #-} + + +-- transpose, applied to a list of lists, returns that list with the +-- "rows" and "columns" interchanged. The input need not be rectangular +-- (a list of equal-length lists) to be completely transposable, but can +-- be "triangular": Each successive component list must be not longer +-- than the previous one; any elements outside of the "triangular" +-- transposable region are lost. The input can be infinite in either +-- dimension or both. +transpose :: [[a]] -> [[a]] +transpose = foldr + (\xs xss -> zipWith (:) xs (xss ++ repeat [])) + [] +{-# transpose :: Inline #-} + +-- zip takes two lists and returns a list of corresponding pairs. If one +-- input list is short, excess elements of the longer list are discarded. +-- zip3 takes three lists and returns a list of triples, etc. Versions +-- of zip producing up to septuplets are defined here. + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (\a b -> (a,b)) +{-# zip :: Inline #-} + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (\a b c -> (a,b,c)) +{-# zip3 :: Inline #-} + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (\a b c d -> (a,b,c,d)) +{-# zip4 :: Inline #-} + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) +{-# zip5 :: Inline #-} + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] + -> [(a,b,c,d,e,f)] +zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f)) +{-# zip6 :: Inline #-} + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] + -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g)) +{-# zip7 :: Inline #-} + +-- The zipWith family generalises the zip family by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, zipWith (+) is applied to two lists to produce the list +-- of corresponding sums. + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z as bs = + build (\ c' n' -> + let f' a g' (b:bs) = c' (z a b) (g' bs) + f' a g' _ = n' + in foldr f' (\ _ -> n') as bs) +--zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +--zipWith _ _ _ = [] +{-# zipWith :: Inline #-} + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z as bs cs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs) + f' a g' _ _ = n' + in foldr f' (\ _ _ -> n') as bs cs) +{-# zipWith3 :: Inline #-} +--zipWith3 z (a:as) (b:bs) (c:cs) +-- = z a b c : zipWith3 z as bs cs +--zipWith3 _ _ _ _ = [] + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z as bs cs ds = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds) + f' a g' _ _ _ = n' + in foldr f' (\ _ _ _ -> n') as bs cs ds) +{-# zipWith4 :: Inline #-} +--zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) +-- = z a b c d : zipWith4 z as bs cs ds +--zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) + -> [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z as bs cs ds es= + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) = + c' (z a b c d e) (g' bs cs ds es) + f' a g' _ _ _ _ = n' + in foldr f' (\ _ _ _ _ -> n') as bs cs ds es) +{-# zipWith5 :: Inline #-} +--zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) +-- = z a b c d e : zipWith5 z as bs cs ds es +--zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) + -> [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z as bs cs ds es fs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = + c' (z a b c d e f) (g' bs cs ds es fs) + f' a g' _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs) +{-# zipWith6 :: Inline #-} +--zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) +-- = z a b c d e f : zipWith6 z as bs cs ds es fs +--zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) + -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z as bs cs ds es fs gs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = + c' (z a b c d e f g) (g' bs cs ds es fs gs) + f' a g' _ _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs) +{-# zipWith7 :: Inline #-} +--zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) +-- = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +--zipWith7 _ _ _ _ _ _ _ _ = [] + + +-- unzip transforms a list of pairs into a pair of lists. As with zip, +-- a family of such functions up to septuplets is provided. + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) +{-# unzip :: Inline #-} + + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) +{-# unzip3 :: Inline #-} + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) +{-# unzip4 :: Inline #-} + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) +{-# unzip5 :: Inline #-} + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) +{-# unzip6 :: Inline #-} + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) +{-# unzip7 :: Inline #-} + diff --git a/progs/prelude/PreludeLocal.hs b/progs/prelude/PreludeLocal.hs new file mode 100644 index 0000000..6e52bbf --- /dev/null +++ b/progs/prelude/PreludeLocal.hs @@ -0,0 +1,16 @@ +module PreludeLocal where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil +data Arrow a b = MkArrow a b + +data Triv = MkTriv diff --git a/progs/prelude/PreludeLocalIO.hs b/progs/prelude/PreludeLocalIO.hs new file mode 100644 index 0000000..2753071 --- /dev/null +++ b/progs/prelude/PreludeLocalIO.hs @@ -0,0 +1,144 @@ +module PreludeLocalIO where + +import PreludeIOPrims +import PreludeIOMonad + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +data IOResponse a = Succ a | Fail String deriving Text + +exec :: ([Response] -> [Request]) -> IO () +{- +-- Sunderesh's original definition +exec p = case (p bottom) of + [] -> unitIO () + (q:qs) -> processRequest q `bindIO` \r -> + exec (\rs -> tail (p (r:rs))) + +bottom :: a +bottom = error "Should never be evaluated" +-} +-- modified from the existing compiler. no quadratic behavior +-- needs +-- pure :: IO a -> a +-- other alternatives: +-- 1. use reference cells +-- 2. implement exec in Lisp + +exec p = os requests `bindIO` \x -> unitIO () where + requests = p responses + responses = pureIO (os requests) + +os :: [Request] -> IO [Response] +os [] = unitIO [] +os (q:qs) = processRequest q `bindIO` \r -> + os qs `bindIO` \rs -> + unitIO (r:rs) + +processRequest :: Request -> IO Response + +-- This needs to be rewritten in terms of the continuation based defs + +processRequest request = + case request of + +-- File system requests + ReadFile name -> + primReadStringFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + WriteFile name contents -> + primWriteStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendFile name contents -> + primAppendStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinFile name -> + primReadBinFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + WriteBinFile name bin -> + primWriteBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendBinFile name bin -> + primAppendBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + DeleteFile name -> + primDeleteFile name `bindIO` \a -> + case a of + MaybeNot -> Success + Maybe e -> unitIO (Failure e) + StatusFile name -> + primStatusFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Channel system requests + ReadChan name -> + primReadChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + AppendChan name string -> + primAppendChan name string `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinChan name -> + primReadBinChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + AppendBinChan name bin -> + primAppendBinChan name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + StatusChan name -> + primStatusChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Environment requests + Echo status -> + primEcho status `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetArgs -> + primGetArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetProgName -> + primProgArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetEnv name -> + primGetEnv name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + SetEnv name string -> + primGetEnv name string `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + _ -> unitIO (Failure (OtherError "Unrecognized IO Feature")) + +-- Monadic Style IO +-- Channel system requests + diff --git a/progs/prelude/PreludePrims.hi b/progs/prelude/PreludePrims.hi new file mode 100644 index 0000000..737a448 --- /dev/null +++ b/progs/prelude/PreludePrims.hi @@ -0,0 +1,252 @@ +-- interface.scm -- define interface to primitives +-- +-- author : Sandra & John +-- date : 24 Apr 1992 +-- +-- This file declares the interface to the runtime system primitives. +-- The actual definitions for the Lisp functions all appear elsewhere; +-- they all have names like prim.xxx. (They can actually be macros +-- instead of functions since they're never referenced by name.) + +interface PreludePrims where + +{-# Prelude #-} + +import PreludeCore(Int,Integer,Float,Double,Char,Bool) +import PreludeRational(Rational) + +error :: String -> a +primCharToInt :: Char -> Int +primIntToChar :: Int -> Char +primEqChar, primNeqChar, primLeChar, primGtChar, primLsChar, primGeChar + :: Char -> Char -> Bool +primMaxChar :: Int +primEqFloat, primNeqFloat, primLeFloat, primGtFloat, primLsFloat, primGeFloat + :: Float -> Float -> Bool +primFloatMax, primFloatMin :: Float -> Float -> Float +primEqDouble, primNeqDouble, primLeDouble, primGtDouble, + primLsDouble, primGeDouble + :: Double -> Double -> Bool +primDoubleMax, primDoubleMin :: Double -> Double -> Double +primPlusFloat, primMinusFloat, primMulFloat, primDivFloat + :: Float -> Float -> Float +primPlusDouble, primMinusDouble, primMulDouble, primDivDouble + :: Double -> Double -> Double +primNegFloat, primAbsFloat :: Float -> Float +primNegDouble, primAbsDouble :: Double -> Double +primExpFloat, primLogFloat, primSqrtFloat, primSinFloat, primCosFloat, + primTanFloat, primAsinFloat, primAcosFloat, primAtanFloat, primSinhFloat, + primCoshFloat, primTanhFloat, primAsinhFloat, primAcoshFloat, primAtanhFloat + :: Float -> Float +primExpDouble, primLogDouble, primSqrtDouble, primSinDouble, primCosDouble, + primTanDouble, primAsinDouble, primAcosDouble, primAtanDouble, primSinhDouble, + primCoshDouble, primTanhDouble, primAsinhDouble, primAcoshDouble, primAtanhDouble + :: Double -> Double +primPiFloat :: Float +primPiDouble :: Double +primRationalToFloat :: Rational -> Float +primRationalToDouble :: Rational -> Double +primFloatToRational :: Float -> Rational +primDoubleToRational :: Double -> Rational +primFloatDigits :: Int +primFloatRadix :: Integer +primFloatMinExp :: Int +primFloatMaxExp :: Int +primFloatRange :: Float -> (Int, Int) +primDecodeFloat :: Float -> (Integer, Int) +primEncodeFloat :: Integer -> Int -> Float +primDoubleDigits :: Int +primDoubleRadix :: Integer +primDoubleMinExp :: Int +primDoubleMaxExp :: Int +primDoubleRange :: Double -> (Int, Int) +primDecodeDouble :: Double -> (Integer, Int) +primEncodeDouble :: Integer -> Int -> Double +primEqInt, primNeqInt, primLeInt, primGtInt, primLsInt, primGeInt + :: Int -> Int -> Bool +primIntMax, primIntMin :: Int -> Int -> Int +primEqInteger, primNeqInteger, primLeInteger, primGtInteger, + primLsInteger, primGeInteger + :: Integer -> Integer -> Bool +primIntegerMax, primIntegerMin :: Integer -> Integer -> Integer +primPlusInt, primMinusInt, primMulInt :: Int -> Int -> Int +primMinInt,primMaxInt :: Int +primNegInt, primAbsInt :: Int -> Int +primPlusInteger, primMinusInteger, primMulInteger :: Integer -> Integer -> Integer +primNegInteger, primAbsInteger :: Integer -> Integer +primQuotRemInt :: Int -> Int -> (Int, Int) +primQuotRemInteger :: Integer -> Integer -> (Integer, Integer) +primIntegerToInt :: Integer -> Int +primIntToInteger :: Int -> Integer +primNullBin :: Bin +primIsNullBin :: Bin -> Bool +primShowBinInt :: Int -> Bin -> Bin +primShowBinInteger :: Integer -> Bin -> Bin +primShowBinFloat :: Float -> Bin -> Bin +primShowBinDouble :: Double -> Bin -> Bin +primReadBinInt :: Bin -> (Int,Bin) +primReadBinInteger :: Bin -> (Integer,Bin) +primReadBinFloat :: Bin -> (Float,Bin) +primReadBinDouble :: Bin -> (Double,Bin) +primReadBinSmallInt :: Bin -> Int -> (Int,Bin) +primAppendBin :: Bin -> Bin -> Bin + +primStringEq :: [Char] -> [Char] -> Bool + +primAppend :: [a] -> [a] -> [a] +primTake :: Int -> [a] -> [a] + +foldr :: (a -> b -> b) -> b -> [a] -> b +build :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] + + + +-- I've assigned complexities for arithmetic primitives as follows: +-- Int and Char comparisons and arithmetic are very cheap (complexity 1). +-- Double and Float comparsions are also cheap, but most implementations +-- need to box the results of floating-point arithmetic so I have given +-- them a complexity of 3. +-- Integer operations need to do an extra bignum check that has a fixed +-- overhead. I assume that actual bignums will be rare and give them +-- all a complexity of 2. + +{-# +error :: LispName("prim.abort") +primCharToInt :: LispName("prim.char-to-int"), Complexity(0),NoConversion +primIntToChar :: LispName("prim.int-to-char"), Complexity(0),NoConversion +primEqChar :: LispName("prim.eq-char"), Complexity(1), NoConversion +primNeqChar:: LispName("prim.not-eq-char"), Complexity(1), NoConversion +primLeChar :: LispName("prim.le-char"), Complexity(1), NoConversion +primGtChar :: LispName("prim.not-le-char"), Complexity(1), NoConversion +primLsChar :: LispName("prim.lt-char"), Complexity(1), NoConversion +primGeChar :: LispName("prim.not-lt-char"), Complexity(1), NoConversion +primMaxChar :: LispName("prim.max-char"), NoConversion +primEqFloat :: LispName("prim.eq-float"), Complexity(1) +primNeqFloat :: LispName("prim.not-eq-float"), Complexity(1) +primLeFloat :: LispName("prim.le-float"), Complexity(1) +primGtFloat :: LispName("prim.not-le-float"), Complexity(1) +primLsFloat :: LispName("prim.lt-float"), Complexity(1) +primGeFloat :: LispName("prim.not-lt-float"), Complexity(1) +primFloatMax :: LispName("prim.float-max"), Complexity(3) +primFloatMin :: LispName("prim.float-min"), Complexity(3) +primEqDouble :: LispName("prim.eq-double"), Complexity(1) +primNeqDouble :: LispName("prim.not-eq-double"), Complexity(1) +primLeDouble :: LispName("prim.le-double"), Complexity(1) +primGtDouble :: LispName("prim.not-le-double"), Complexity(1) +primLsDouble :: LispName("prim.lt-double"), Complexity(1) +primGeDouble :: LispName("prim.not-lt-double"), Complexity(1) +primDoubleMax :: LispName("prim.double-max"), Complexity(3) +primDoubleMin :: LispName("prim.double-min"), Complexity(3) +primPlusFloat :: LispName("prim.plus-float"), Complexity(3) +primMinusFloat :: LispName("prim.minus-float"), Complexity(3) +primMulFloat :: LispName("prim.mul-float"), Complexity(3) +primDivFloat :: LispName("prim.div-float"), Complexity(3) +primPlusDouble :: LispName("prim.plus-double"), Complexity(3) +primMinusDouble :: LispName("prim.minus-double"), Complexity(3) +primMulDouble :: LispName("prim.mul-double"), Complexity(3) +primDivDouble :: LispName("prim.div-double"), Complexity(3) +primNegFloat :: LispName("prim.neg-float"), Complexity(3) +primAbsFloat :: LispName("prim.abs-float"), Complexity(3) +primNegDouble :: LispName("prim.neg-double"), Complexity(3) +primAbsDouble :: LispName("prim.abs-double"), Complexity(3) +primExpFloat :: LispName("prim.exp-float") +primLogFloat :: LispName("prim.log-float") +primSqrtFloat :: LispName("prim.sqrt-float") +primSinFloat :: LispName("prim.sin-float") +primCosFloat :: LispName("prim.cos-float") +primTanFloat :: LispName("prim.tan-float") +primAsinFloat :: LispName("prim.asin-float") +primAcosFloat :: LispName("prim.acos-float") +primAtanFloat :: LispName("prim.atan-float") +primSinhFloat :: LispName("prim.sinh-float") +primCoshFloat :: LispName("prim.cosh-float") +primTanhFloat :: LispName("prim.tanh-float") +primAsinhFloat :: LispName("prim.asinh-float") +primAcoshFloat :: LispName("prim.acosh-float") +primAtanhFloat :: LispName("prim.atanh-float") +primExpDouble :: LispName("prim.exp-double") +primLogDouble :: LispName("prim.log-double") +primSqrtDouble :: LispName("prim.sqrt-double") +primSinDouble :: LispName("prim.sin-double") +primCosDouble :: LispName("prim.cos-double") +primTanDouble :: LispName("prim.tan-double") +primAsinDouble :: LispName("prim.asin-double") +primAcosDouble :: LispName("prim.acos-double") +primAtanDouble :: LispName("prim.atan-double") +primSinhDouble :: LispName("prim.sinh-double") +primCoshDouble :: LispName("prim.cosh-double") +primTanhDouble :: LispName("prim.tanh-double") +primAsinhDouble :: LispName("prim.asinh-double") +primAcoshDouble :: LispName("prim.acosh-double") +primAtanhDouble :: LispName("prim.atanh-double") +primPiFloat :: LispName("prim.pi-float") +primPiDouble :: LispName("prim.pi-double") +primRationalToFloat :: LispName("prim.rational-to-float"), Complexity(3) +primRationalToDouble :: LispName("prim.rational-to-double"), Complexity(3) +primFloatToRational :: LispName("prim.float-to-rational"), Complexity(3) +primDoubleToRational :: LispName("prim.double-to-rational"), Complexity(3) +primFloatDigits :: LispName("prim.float-digits") +primFloatRadix :: LispName("prim.float-radix") +primFloatMinExp :: LispName("prim.float-min-exp") +primFloatMaxExp :: LispName("prim.float-max-exp") +primFloatRange :: LispName("prim.float-range") +primDecodeFloat :: LispName("prim.decode-float") +primEncodeFloat :: LispName("prim.encode-float") +primDoubleDigits :: LispName("prim.double-digits") +primDoubleRadix :: LispName("prim.double-radix") +primDoubleMinExp :: LispName("prim.double-min-exp") +primDoubleMaxExp :: LispName("prim.double-max-exp") +primDoubleRange :: LispName("prim.double-range") +primDecodeDouble :: LispName("prim.decode-double") +primEncodeDouble :: LispName("prim.encode-double") +primEqInt :: LispName("prim.eq-int"), Complexity(1) +primNeqInt:: LispName("prim.not-eq-int"), Complexity(1) +primLeInt :: LispName("prim.le-int"), Complexity(1) +primGtInt :: LispName("prim.not-le-int"), Complexity(1) +primLsInt :: LispName("prim.lt-int"), Complexity(1) +primGeInt :: LispName("prim.not-lt-int"), Complexity(1) +primIntMax :: LispName("prim.int-max"), Complexity(1) +primIntMin :: LispName("prim.int-min"), Complexity(1) +primEqInteger :: LispName("prim.eq-integer"), Complexity(2) +primNeqInteger:: LispName("prim.not-eq-integer"), Complexity(2) +primLeInteger :: LispName("prim.le-integer"), Complexity(2) +primGtInteger :: LispName("prim.not-le-integer"), Complexity(2) +primLsInteger :: LispName("prim.lt-integer"), Complexity(2) +primGeInteger :: LispName("prim.not-lt-integer"), Complexity(2) +primIntegerMax :: LispName("prim.integer-max"), Complexity(2) +primIntegerMin :: LispName("prim.integer-min"), Complexity(2) +primPlusInt :: LispName("prim.plus-int"), Complexity(1) +primMinusInt :: LispName("prim.minus-int"), Complexity(1) +primMulInt :: LispName("prim.mul-int"), Complexity(1) +primMinInt :: LispName("prim.minint") +primMaxInt :: LispName("prim.maxint") +primNegInt :: LispName("prim.neg-int"), Complexity(1) +primAbsInt :: LispName("prim.abs-int"), Complexity(1) +primPlusInteger :: LispName("prim.plus-integer"), Complexity(2) +primMinusInteger :: LispName("prim.minus-integer"), Complexity(2) +primMulInteger :: LispName("prim.mul-integer"), Complexity(2) +primNegInteger :: LispName("prim.neg-integer"), Complexity(2) +primAbsInteger :: LispName("prim.abs-integer"), Complexity(2) +primQuotRemInt :: LispName("prim.div-rem-int") +primQuotRemInteger :: LispName("prim.div-rem-integer") +primIntegerToInt :: LispName("prim.integer-to-int"), Complexity(1) +primIntToInteger :: LispName("prim.int-to-integer"), Complexity(0) +primNullBin :: LispName("prim.nullbin") +primIsNullBin :: LispName("prim.is-null-bin"), Complexity(1) +primShowBinInt :: LispName("prim.show-bin-int"), Complexity(2) +primShowBinInteger :: LispName("prim.show-bin-integer"), Complexity(2) +primShowBinFloat :: LispName("prim.show-bin-float"), Complexity(2) +primShowBinDouble :: LispName("prim.show-bin-double"), Complexity(2) +primReadBinInt :: LispName("prim.read-bin-int") +primReadBinInteger :: LispName("prim.read-bin-integer") +primReadBinFloat :: LispName("prim.read-bin-float") +primReadBinDouble :: LispName("prim.read-bin-double") +primReadBinSmallInt :: LispName("prim.read-bin-small-int") +primAppendBin :: LispName("prim.append-bin") +primStringEq :: LispName("prim.string-eq"), Strictness("S,S"), NoConversion +primAppend :: LispName("prim.append"), Strictness("S,N"), NoConversion +primTake :: LispName("prim.take"), Strictness("S,S"), NoConversion +foldr :: LispName("prim.foldr"), Strictness("N,N,S"), NoConversion +build :: LispName("prim.build"), Strictness("S"), NoConversion + +#-} diff --git a/progs/prelude/PreludePrims.hu b/progs/prelude/PreludePrims.hu new file mode 100644 index 0000000..fd2cdcc --- /dev/null +++ b/progs/prelude/PreludePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludePrims +:stable +:prelude +PreludePrims.hi diff --git a/progs/prelude/PreludeRatio.hs b/progs/prelude/PreludeRatio.hs new file mode 100644 index 0000000..564558e --- /dev/null +++ b/progs/prelude/PreludeRatio.hs @@ -0,0 +1,98 @@ +-- Standard functions on rational numbers + +module PreludeRatio ( + Ratio, Rational(..), (%), numerator, denominator, approxRational ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 7 %, :% + +prec = 7 + +data (Integral a) => Ratio a = a {-# STRICT #-} :% a {-# STRICT #-} + deriving (Eq, Binary) + +type Rational = Ratio Integer + +(%) :: (Integral a) => a -> a -> Ratio a +numerator, denominator :: (Integral a) => Ratio a -> a +approxRational :: (RealFrac a) => a -> a -> Rational + + +reduce _ 0 = error "(%){PreludeRatio}: zero denominator" +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y + + +x % y = reduce (x * signum y) (abs y) + +numerator (x:%y) = x + +denominator (x:%y) = y + + +instance (Integral a) => Ord (Ratio a) where + (x:%y) <= (x':%y') = x * y' <= x' * y + (x:%y) < (x':%y') = x * y' < x' * y + +instance (Integral a) => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x * x') (y * y') + negate (x:%y) = (-x) :% y + abs (x:%y) = abs x :% y + signum (x:%y) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + +instance (Integral a) => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance (Integral a) => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + +instance (Integral a) => RealFrac (Ratio a) where + properFraction (x:%y) = (fromIntegral q, r:%y) + where (q,r) = quotRem x y + +instance (Integral a) => Enum (Ratio a) where + enumFrom = iterate ((+)1) + enumFromThen n m = iterate ((+)(m-n)) n + +instance (Integral a) => Text (Ratio a) where + readsPrec p = readParen (p > prec) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + + showsPrec p (x:%y) = showParen (p > prec) + (shows x . showString " % " . shows y) + + +-- approxRational, applied to two real fractional numbers x and epsilon, +-- returns the simplest rational number within epsilon of x. A rational +-- number n%d in reduced form is said to be simpler than another n'%d' if +-- abs n <= abs n' && d <= d'. Any real interval contains a unique +-- simplest rational; here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +approxRational x eps = simplest (x-eps) (x+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr@(n:%d) = toRational x + (n':%d') = toRational y + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + (n'':%d'') = simplest' d' r' d r diff --git a/progs/prelude/PreludeText.hs b/progs/prelude/PreludeText.hs new file mode 100644 index 0000000..9e4e353 --- /dev/null +++ b/progs/prelude/PreludeText.hs @@ -0,0 +1,260 @@ +module PreludeText ( + reads, shows, show, read, lex, + showChar, showString, readParen, showParen, readLitChar, showLitChar, + readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +reads :: (Text a) => ReadS a +reads = readsPrec 0 + +shows :: (Text a) => a -> ShowS +shows = showsPrec 0 + +read :: (Text a) => String -> a +read s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error "read{PreludeText}: no parse" + _ -> error "read{PreludeText}: ambiguous parse" + +show :: (Text a) => a -> String +show x = shows x "" + +showChar :: Char -> ShowS +showChar = (:) + +showString :: String -> ShowS +showString = (++) + +showParen :: Bool -> ShowS -> ShowS +showParen b p = if b then showChar '(' . p . showChar ')' else p + +readParen :: Bool -> ReadS a -> ReadS a +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = [(x,u) | ("(",s) <- lex r, + (x,t) <- optional s, + (")",u) <- lex t ] + +lex :: ReadS String +lex "" = [("","")] +lex (c:s) | isSpace c = lex (dropWhile isSpace s) +lex ('-':'-':s) = case dropWhile (/= '\n') s of + '\n':t -> lex t + _ -> [] -- unterminated end-of-line + -- comment + +lex ('{':'-':s) = lexNest lex s + where + lexNest f ('-':'}':s) = f s + lexNest f ('{':'-':s) = lexNest (lexNest f) s + lexNest f (c:s) = lexNest f s + lexNest _ "" = [] -- unterminated + -- nested comment + +lex ('<':'-':s) = [("<-",s)] +lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, + ch /= "'" ] +lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] + where + lexString ('"':s) = [("\"",s)] + lexString s = [(ch++str, u) + | (ch,t) <- lexStrItem s, + (str,u) <- lexString t ] + + lexStrItem ('\\':'&':s) = [("\\&",s)] + lexStrItem ('\\':c:s) | isSpace c + = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = [([c],s)] + | isSym1 c = [(c:sym,t) | (sym,t) <- [span isSym s]] + | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] + | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], + (fe,t) <- lexFracExp s ] + | otherwise = [] -- bad character + where + isSingle c = c `elem` ",;()[]{}_" + isSym1 c = c `elem` "-~" || isSym c + isSym c = c `elem` "!@#$%&*+./<=>?\\^|:" + isIdChar c = isAlphanum c || c `elem` "_'" + + lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, + (e,u) <- lexExp t ] + lexFracExp s = [("",s)] + + lexExp (e:s) | e `elem` "eE" + = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", + (ds,u) <- lexDigits t] ++ + [(e:ds,t) | (ds,t) <- lexDigits s] + lexExp s = [("",s)] + +lexDigits :: ReadS String +lexDigits = nonnull isDigit + +nonnull :: (Char -> Bool) -> ReadS String +nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] + +lexLitChar :: ReadS String +lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] + lexEsc s@(d:_) | isDigit d = lexDigits s + lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s] + lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s] + lexEsc s@(c:_) | isUpper c + = case [(mne,s') | mne <- "DEL" : elems asciiTab, + ([],s') <- [match mne s] ] + of (pr:_) -> [pr] + [] -> [] + lexEsc _ = [] +lexLitChar (c:s) = [([c],s)] +lexLitChar "" = [] + +isOctDigit c = c >= '0' && c <= '7' +isHexDigit c = isDigit c || c >= 'A' && c <= 'F' + || c >= 'a' && c <= 'f' + +match :: (Eq a) => [a] -> [a] -> ([a],[a]) +match (x:xs) (y:ys) | x == y = match xs ys +match xs ys = (xs,ys) + +asciiTab = listArray ('\NUL', ' ') + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] + + + +readLitChar :: ReadS Char +readLitChar ('\\':s) = readEsc s + where + readEsc ('a':s) = [('\a',s)] + readEsc ('b':s) = [('\b',s)] + readEsc ('f':s) = [('\f',s)] + readEsc ('n':s) = [('\n',s)] + readEsc ('r':s) = [('\r',s)] + readEsc ('t':s) = [('\t',s)] + readEsc ('v':s) = [('\v',s)] + readEsc ('\\':s) = [('\\',s)] + readEsc ('"':s) = [('"',s)] + readEsc ('\'':s) = [('\'',s)] + readEsc ('^':c:s) | c >= '@' && c <= '_' + = [(chr (ord c - ord '@'), s)] + readEsc s@(d:_) | isDigit d + = [(chr n, t) | (n,t) <- readDec s] + readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] + readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] + readEsc s@(c:_) | isUpper c + = let table = ('\DEL' := "DEL") : assocs asciiTab + in case [(c,s') | (c := mne) <- table, + ([],s') <- [match mne s]] + of (pr:_) -> [pr] + [] -> [] + readEsc _ = [] +readLitChar (c:s) = [(c,s)] + +showLitChar :: Char -> ShowS +showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) +showLitChar '\DEL' = showString "\\DEL" +showLitChar '\\' = showString "\\\\" +showLitChar c | c >= ' ' = showChar c +showLitChar '\a' = showString "\\a" +showLitChar '\b' = showString "\\b" +showLitChar '\f' = showString "\\f" +showLitChar '\n' = showString "\\n" +showLitChar '\r' = showString "\\r" +showLitChar '\t' = showString "\\t" +showLitChar '\v' = showString "\\v" +showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") +showLitChar c = showString ('\\' : asciiTab!c) + +protectEsc p f = f . cont + where cont s@(c:_) | p c = "\\&" ++ s + cont s = s + +readDec, readOct, readHex :: (Integral a) => ReadS a +readDec = readInt 10 isDigit (\d -> ord d - ord '0') +readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') +readHex = readInt 16 isHexDigit hex + where hex d = ord d - (if isDigit d then ord '0' + else ord (if isUpper d then 'A' else 'a') + - 10) + +readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a +readInt radix isDig digToInt s = + [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r) + | (ds,r) <- nonnull isDig s ] + +showInt :: (Integral a) => a -> ShowS +showInt n r = let (n',d) = quotRem n 10 + r' = chr (ord '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + +readSigned:: (Real a) => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + [(-x,t) | ("-",s) <- lex r, + (x,t) <- read'' s] + read'' r = [(n,s) | (str,s) <- lex r, + (n,"") <- readPos str] + +showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x = if x < 0 then showParen (p > 6) + (showChar '-' . showPos (-x)) + else showPos x + + +-- The functions readFloat and showFloat below use rational arithmetic +-- to insure correct conversion between the floating-point radix and +-- decimal. It is often possible to use a higher-precision floating- +-- point type to obtain the same results. + +readFloat:: (RealFloat a) => ReadS a +readFloat r = [(fromRational ((n%1)*10^^(k-d)), t) | (n,d,s) <- readFix r, + (k,t) <- readExp s] + where readFix r = [(read (ds++ds'), length ds', t) + | (ds,'.':s) <- lexDigits r, + (ds',t) <- lexDigits s ] + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = [(0,s)] + + readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] + readExp' ('+':s) = readDec s + readExp' s = readDec s + +-- The number of decimal digits m below is chosen to guarantee +-- read (show x) == x. See +-- Matula, D. W. A formalization of floating-point numeric base +-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), +-- 681-692. + +showFloat:: (RealFloat a) => a -> ShowS +showFloat x = + if x == 0 then showString ("0." ++ take (m-1) (repeat '0')) + else if e >= m-1 || e < 0 then showSci else showFix + where + showFix = showString whole . showChar '.' . showString frac + where (whole,frac) = splitAt (e+1) (show sig) + showSci = showChar d . showChar '.' . showString frac + . showChar 'e' . shows e + where (d:frac) = show sig + (m, sig, e) = if b == 10 then (w, s, n+w-1) + else (m', sig', e' ) + m' = ceiling + (fromIntegral w * log (fromInteger b) / log 10 :: Double) + + 1 + (sig', e') = if sig1 >= 10^m' then (round (t/10), e1+1) + else if sig1 < 10^(m'-1) then (round (t*10), e1-1) + else (sig1, e1 ) + sig1 :: Integer + sig1 = round t + t = s%1 * (b%1)^^n * 10^^(m'-e1-1) + e1 = floor (logBase 10 x) + (s, n) = decodeFloat x + b = floatRadix x + w = floatDigits x diff --git a/progs/prelude/PreludeTuple.hs b/progs/prelude/PreludeTuple.hs new file mode 100644 index 0000000..4f2637a --- /dev/null +++ b/progs/prelude/PreludeTuple.hs @@ -0,0 +1,213 @@ +module PreludeTuple where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludeTuplePrims + +-- This module contains support routines which handle tuple instances. +-- These are based on a implementation level data type which represents +-- general tuples and a data type to hold the set of dictionaries which +-- are associated with the tuple. + +-- Each of these functions takes the tupledicts as the first argument. +-- Force all of these functions to take strict arguments because they'll +-- never be called with 0-length tuples anyway. + +-- The following primitives operate on tuples. + +-- tupleSize :: TupleDicts -> Int +-- tupleSel :: Tuple -> Int -> Int -> a +-- dictSel :: TupleDicts -> method -> Int -> a +-- listToTuple :: [a] -> Tuple + +-- Eq functions + +tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleEq :: Strictness("S,S,S") #-} +tupleEq dicts x y = tupleEq1 0 where + tupleEq1 i | i == size = True + | otherwise = + ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1) + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpEq x y = x == y + +tupleNeq dicts x y = not (tupleEq dicts x y) + +-- Ord functions + +tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLe :: Strictness("S,S,S") #-} +tupleLe dicts x y = tupleLe1 0 where + tupleLe1 i | i == size = False + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpLs x y = x < y + +ordEq :: Ord a => a -> a -> Bool +ordEq x y = x == y + +tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLeq :: Strictness("S,S,S") #-} +tupleLeq dicts x y = tupleLeq1 0 where + tupleLeq1 i | i == size = True + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGe d x y = tupleLe d y x + +tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGeq d x y = tupleLeq d y x + +tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple +tupleMax d x y = if tupleGe d x y then x else y +tupleMin d x y = if tupleLe d x y then x else y + +-- Ix functions + +tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple] +{-# tupleRange :: Strictness("S,S") #-} + +tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where + tupleRange' i | i == size = [[]] + | otherwise = + [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)] + where + x' = tupleSel x i size + y' = tupleSel y i size + r = (dictSel (range' dicts i)) (x',y') + size = tupleSize dicts + +range' x = range x + +tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int +{-# tupleIndex :: Strictness("S,S,S") #-} + +tupleIndex dicts (low,high) n = tupleIndex' (size-1) where + size = tupleSize dicts + tupleIndex' i | i == 0 = i' + | otherwise = i' + r' * (tupleIndex' (i-1)) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + i' = (dictSel (index' dicts i)) (low',high') n' + r' = (dictSel (rangeSize dicts i)) (low',high') + +index' x = index x + +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool +{-# tupleInRange :: Strictness("S,S,S") #-} +tupleInRange dicts (low,high) n = tupleInRange' 0 where + size = tupleSize dicts + tupleInRange' i | i == size = True + | otherwise = (dictSel (inRange' dicts i)) (low',high') n' + && tupleInRange' (i+1) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + +inRange' x = inRange x + +-- Text functions + +tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple + +tupleReadsPrec dicts p = readParen False + (\s -> map ( \ (t,w) -> (listToTuple t,w)) + (tRP' s 0)) + where + size = tupleSize dicts + tRP' s i | i == 0 = [(t':t,w) | + ("(",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + | i == size = [([],w) | (")",w) <- lex s] + | otherwise = + [(t':t,w) | + (",",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + where + nextItem s = (dictSel (reads dicts i)) s + +tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS + +tupleShowsPrec dicts p tuple = + showChar '(' . tSP' 0 + where + size = tupleSize dicts + tSP' i | i == (size-1) = + showTup . showChar ')' + | otherwise = + showTup . showChar ',' . tSP' (i+1) + where + showTup = (dictSel (shows dicts i)) (tupleSel tuple i size) + +tupleReadList :: TupleDicts -> ReadS [Tuple] + +tupleReadList dicts = + readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- tupleReads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- tupleReads t, + (xs,v) <- readl' u] + tupleReads s = tupleReadsPrec dicts 0 s + +tupleShowList :: TupleDicts -> [Tuple] -> ShowS + +tupleShowList dicts [] = showString "[]" +tupleShowList dicts (x:xs) + = showChar '[' . showsTuple x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . showsTuple x + . showl xs + showsTuple x = tupleShowsPrec dicts 0 x + +-- Binary functions + +tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin + +tupleShowBin dicts t bin = tSB' 0 + where + size = tupleSize dicts + tSB' i | i == size = bin + tSB' i | otherwise = + (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1)) + +showBin' x = showBin x + +tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin) + +tupleReadBin dicts bin = (listToTuple t,b) where + size = tupleSize dicts + (t,b) = tRB' bin 0 + tRB' b i | i == size = ([],b) + | otherwise = (t':ts,b') where + (t',b'') = (dictSel (readBin' dicts i)) b + (ts,b') = tRB' b'' (i+1) + +readBin' x = readBin x diff --git a/progs/prelude/PreludeTuplePrims.hi b/progs/prelude/PreludeTuplePrims.hi new file mode 100644 index 0000000..6af0dfd --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hi @@ -0,0 +1,48 @@ + +-- This is the interface to the primitives used to implement arbitrary +-- sized tuples. + +interface PreludeTuplePrims where + +{-# Prelude #-} + +-- The type checker fiddles around with the call to dictSel to use the +-- dictionary to resolve the overloading of a subexpression. The call +-- dictSel (exp dict i) will typecheck exp and use the ith component of +-- the tupleDict dict to resolve the overloading. No check is made to ensure +-- that the type of the dictionary matches the overloaded class! Beware! + +import PreludeData(Int) + +data Tuple +data TupleDicts + + +tupleSize :: TupleDicts -> Int +tupleSel :: Tuple -> Int -> Int -> a +dictSel :: TupleDicts -> Int -> a +listToTuple :: [a] -> Tuple +-- These are not called by haskell code directly; these are introduced +-- during dictionary conversion by the type checker. +tupleEqDict :: a +tupleOrdDict :: a +tupleIxDict :: a +tupleTextDict :: a +tupleBinaryDict :: a + +{-# +tupleSize :: LispName("prim.tupleSize"), Complexity(1) +tupleSel :: LispName("prim.tupleSel") +dictSel :: LispName("prim.dict-sel") +listToTuple :: LispName("prim.list->tuple"), NoConversion +tupleEqDict :: LispName("prim.tupleEqDict") +tupleOrdDict :: LispName("prim.tupleOrdDict") +tupleIxDict :: LispName("prim.tupleIxDict") +tupleTextDict :: LispName("prim.tupleTextDict") +tupleBinaryDict :: LispName("prim.tupleBinaryDict") + +#-} + + + + diff --git a/progs/prelude/PreludeTuplePrims.hu b/progs/prelude/PreludeTuplePrims.hu new file mode 100644 index 0000000..eaa0385 --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeTuplePrims +:stable +:prelude +PreludeTuplePrims.hi diff --git a/progs/prelude/README b/progs/prelude/README new file mode 100644 index 0000000..2decc21 --- /dev/null +++ b/progs/prelude/README @@ -0,0 +1,12 @@ + +This is the actual prelude used by the Yale system. This contains a many +small changes to the standard prelude, mostly optimizer annotations. +PreludeIO is totally different since we have flushed streams in favor +of the monad. Primitives are defined using the Haskell to Lisp interface. + +Arrays are implemented internally using destructive updates - no array +primitive involves more than one copy operation and lookup is constant +time. + +The data constructors for Complex and Rational are strict. + diff --git a/progs/tutorial/README b/progs/tutorial/README new file mode 100644 index 0000000..defe248 --- /dev/null +++ b/progs/tutorial/README @@ -0,0 +1,12 @@ + +This is the text of the online version of the tutorial. It is set up to +run under Emacs only. Form feeds divide the pages of the tutorial. Emacs +has a special mode just for the tutorial which makes a local copy of each +page for the user to scribble on without disturbing this source. + +It is possible that this could be adapted to the command interface by +breaking it up into one file per page. + +This is still preliminary - we need to work on the text and examples. +Please send comments to haskell-request@cs.yale.edu. + diff --git a/progs/tutorial/tutorial.hs b/progs/tutorial/tutorial.hs new file mode 100644 index 0000000..eb6a78d --- /dev/null +++ b/progs/tutorial/tutorial.hs @@ -0,0 +1,2143 @@ +-- Page 0 Introduction + +This is a programming supplement to `A Gentle Introduction to Haskell' +by Hudak and Fasel. This supplement augments the tutorial by +providing executable Haskell programs which you can run and +experiment with. All program fragments in the tutorial are +found here, as well as other examples not included in the tutorial. + + +Using This Tutorial + +You should have a copy of both the `Gentle Introduction' and the +report itself to make full use of this tutorial. Although the +`Gentle Introduction' is meant to stand by itself, it is often easier +to learn a language through actual use and experimentation than by +reading alone. Once you finish this introduction, we recommend that +you proceed section by section through the `Gentle Introduction' and +after having read each section go back to this online tutorial. You +should wait until you have finished the tutorial before attempting to +read the report. We assume that you are familiar with the basics of +Emacs and that Haskell has been installed at your site. + +This tutorial does not assume any familiarity with Haskell or other +functional languages. However, knowledge of almost-functional +languages such as ML or Scheme is very useful. Throughout the +online component of this tutorial, we try to relate Haskell to +other programming languages and clarify the written tutorial through +additional examples and text. + + +Organization of the Online Tutorial + +This online tutorial is divided into a series of pages. Each page +covers one or more sections in the written tutorial. You can use +special Emacs commands to move back and forth through the pages of the +online tutorial. Each page is a single Haskell program. Comments in +the program contain the text of the online tutorial. You can modify +the program freely (this will not change the underlying tutorial +file!) and ask the system to print the value of expressions defined in +the program. + +At the beginning of each page, the sections covered by the page are +listed. In addition, the start of each individual section is +marked within each page. Emacs commands can take you directly to a +specific page or section in the tutorial. + +To create useful, executable examples of Haskell code, some language +constructs need to be revealed well before they are explained in the +tutorial. We attempt to point these out when they occur. Some +small changes have been made to the examples in the written tutorial; +these are usually cosmetic and should be ignored. Don't feel you have +to understand everything on a page before you move on -- many times +concepts become clearer as you move on and can relate them to other +aspect of the language. + +Each page of the tutorial defines a set of variables. Some of +these are named e1, e2, and so on. These `e' variables are the ones +which are meant for you to evaluate as you go through the tutorial. +Of course you may evaluate any other expressions or variables you wish. + + +The Haskell Report + +While the report is not itself a tutorial on the Haskell language, it +can be an invaluable reference to even a novice user. A very +important feature of Haskell is the prelude. The prelude is a +rather large chunk of Haskell code which is implicitly a part of every +Haskell program. Whenever you see functions used which are not +defined in the current page, these come from the Prelude. Appendix A +of the report lists the entire Prelude; the index has an entry for +every function in the Prelude. Looking at the definitions in the +Prelude is sometimes necessary to fully understand the programs in +this tutorial. + +Another reason to look at the report is to understand the syntax of +Haskell. Appendix B contains the complete syntax for Haskell. The +tutorial treats the syntax very informally; the precise details are +found only in the report. + + +The Yale Haskell System + +This version of the tutorial runs under version Y2.0 of Yale Haskell. +The Yale Haskell system is an interactive programming environment for +the Haskell language. The system is best used in conjunction with the +Emacs editor. Yale Haskell is available free of change via ftp. + + +Using the Compiler + +Yale Haskell runs as a subprocess under Emacs. While many commands +are available to the Yale Haskell user, a single command is the +primary means of communicating with the compiler: C-c e. This command +evaluates and prints an expression in the context of the program on +the screen. Here is what this command does: + +a) You are prompted for an expression in the minibuffer. You can +use M-p or M-n to move through a ring of previous inputs. + +b) If an inferior Haskell process is not running, a buffer named *haskell* +is created and the Haskell compiler is started up. The *haskell* buffer +pops onto your screen. + +c) If the program in the current page of the tutorial has not yet been +compiled or the page has been modified after its most recent +compilation, the entire page is compiled. This may result in a short delay. + +d) If there are no errors in the program, the expression entered in +step a) is compiled in the context of the program. Any value defined +in the current page can be referenced. + +e) If there are no errors in the expression, its value is printed in +the *haskell* buffer. + +There are also a few other commands you can use. C-c i interrupts +the Haskell program. Some tight loops cannot be interrupted; in this +case you will have to kill the Haskell process. C-c q exits the Haskell +process. + + +Emacs Commands Used by the Tutorial + +These commands are specific to the tutorial. The tutorial is entered +using M-x haskell-tutorial and is exited with C-c q. To move among +the pages of the tutorial, use + +C-c C-f -- go forward 1 page +C-c C-b -- go back 1 page +M-x ht-goto-page - goto a specific page of the tutorial +M-x ht-goto-section - goto a specific section of the tutorial + +Each page of the tutorial can be modified without changing the +underlying text of the tutorial. Changes are not saved as you go +between pages. To revert a page to its original form use C-c C-l. + +You can get help regarding the Emacs commands with C-c ?. + +Summary of Emacs commands used by the tutorial: + M-x haskell-tutorial - start the tutorial + C-c C-f - Go to the next page of the tutorial program + C-c C-b - Go back to the previous page of the tutorial program + C-c C-l - Restore the current page to its original form + C-c e - Evaluate a Haskell expression + C-c i - Interrupt a running Haskell program + C-c ? - Shows a help message + M-x ht-goto-page - goto a specific page of the tutorial + M-x ht-goto-section - goto a specific section of the tutorial + + +You are now ready to start the tutorial. Start by reading the `Gentle +Introduction' section 1 then proceed through the online tutorial using +C-c C-f to advance to the next page. You should read about each topic +first before turning to the associated programming example in the +online tutorial. + + +-- Page 1 Section 2 + +-- Section 2 Values, Types, and Other Goodies + +-- Haskell uses `--' to designate end of line comments. We use these +-- throughout the tutorial to place explanatory text in the program. + +-- Remember to use C-c e to evaluate expressions, C-c ? for help. + +-- All Haskell programs must start with a module declaration. Ignore this +-- for now. + +module Test(Bool) where + +-- We will start by defining some identifiers (variables) using equations. +-- You can print out the value of an identifier by typing C-c e and +-- typing the name of the identifier you wish to evaluate. This will +-- compile the entire program, not just the line with the definition +-- you want to see. Not all definitions are very interesting to print out - +-- by convention, we will use variables e1, e2, ... to denote values that +-- are `interesting' to print. + +-- We'll start with some constants as well as their associated type. +-- There are two ways to associate a type with a value: a type declaration +-- and an expression type signature. Here is an equation and a type +-- declaration: + +e1 :: Int -- This is a type declaration for the identifier e1 +e1 = 5 -- This is an equation defining e1 + +-- You can evaluate the expression e1 and watch the system print `5'! Wow! + +-- Remember that C-c e is prompting for an expression. Expressions like +-- e1 or 5 or 1+1 are all valid. However, `e1 = 5' is a definition, +-- not an expression. Trying to evaluate it will result in a syntax error. + +-- The type declaration for e1 is not really necessary but we will try to +-- always provide type declarations for values to help document the program +-- and to ensure that the system infers the same type we do for an expression. +-- If you change the value for e1 to `True', the program will no longer +-- compile due to the type mismatch. + +-- We will briefly mention expression type signatures: these are attached to +-- expressions instead of identifiers. Here are equivalent ways to do +-- the previous definition: + +e2 = 5 :: Int +e3 = (2 :: Int) + (3 :: Int) + +-- The :: has very low precedence in expressions and should usually be placed +-- in parenthesis. + +-- Note that there are two completely separate languages: an expression +-- language for values and a type language for type signatures. The type +-- language is used only in the type declarations previously described and +-- declarations of new types, described later. Haskell uses a +-- uniform syntax so that values resemble their type signature as much as +-- possible. However, you must always be aware of the difference between +-- type expressions and value expressions. + +-- Here are some of the predefined types Haskell provides: +-- type Value Syntax Type Syntax +-- Small integers <digits> Int +e4 :: Int +e4 = 12345 +-- Characters '<character>' Char +e5 :: Char +e5 = 'a' +-- Boolean True, False Bool +e6 :: Bool +e6 = True +-- Floating point <digits.digits> Float +e7 :: Float +e7 = 123.456 +-- We will introduce these types now; there will be much more to say later. +-- Homogenous List [<exp1>,<exp2>,...] [<constituant type>] +e8 :: [Int] +e8 = [1,2,3] +-- Tuple (<exp1>,<exp2>,...) (<exp1-type>,<exp2-type>,...) +e9 :: (Char,Int) +e9 = ('b',4) +-- Functional described later domain type -> range type +succ :: Int -> Int -- a function which takes an Int argument and returns Int +succ x = x + 1 -- test this by evaluating `succ 4' + +-- Here's a few leftover examples from section 2: + +e10 = succ (succ 3) -- you could also evaluate `succ (succ 3)' directly + -- by entering the entire expression to the C-c e + +-- If you want to evaluate something more complex than the `e' variables +-- defined here, it is better to enter a complex expression, such as +-- succ (succ 3), directly than to edit a new definition like e10 into +-- the program. This is because any change to the program will require +-- recompilation of the entire page. The expressions entered to C-c e are +-- compiled separately (and very quickly!). + +-- Uncomment this next line to see a compile time type error. +-- e11 = 'a'+'b' +-- Don't worry about the error message - it will make more sense later. + +-- Proceed to the next page using C-c C-f + +-- Page 2 Section 2.1 + +-- Section 2.1 Polymorphic Types + +module Test(Bool) where + +-- The following line allows us to redefine functions in the standard +-- prelude. Ignore this for now. + +import Prelude hiding (length,head,tail,null) + +-- start with some sample lists to use in test cases + +list1 :: [Int] +list1 = [1,2,3] +list2 :: [Char] -- This is the really a string +list2 = ['a','b','c'] -- This is the same as "abc"; evaluate list2 and see. +list3 :: [[a]] -- The element type of the inner list is unknown +list3 = [[],[],[],[]] -- so this list can't be printed +list4 :: [Int] +list4 = 1:2:3:4:[] -- Exactly the same as [1,2,3,4]; print it and see. + +-- This is the length function. You can test it by evaluating expressions +-- such as `length list1'. Function application is written by +-- simple juxtaposition: `f(x)' in other languages would be `f x' in Haskell. + +length :: [a] -> Int +length [] = 0 +length (x:xs) = 1 + length xs + +-- Function application has the highest precedence, so 1 + length xs is +-- parsed as 1 + (length xs). In general, you have to surround +-- non-atomic arguments to a function with parens. This includes +-- arguments which are also function applications. For example, +-- f g x is the function f applied to arguments g and x, similar to +-- f(g,x) in other languages. However, f (g x) is f applied to (g x), or +-- f(g(x)), which means something quite different! Be especially +-- careful with infix operators: f x+1 y-2 would be parsed as (f x)+(1 y)-2. +-- This is also true on the left of the `=': the parens around (x:xs) are +-- absolutely necessary. length x:xs would be parsed as (length x):xs. + +-- Also be careful with prefix negation, -. The application `f -1' is +-- f-1, not f(-1). Add parens around negative numbers to avoid this +-- problem. + +-- Here are some other list functions: + +head :: [a] -> a -- returns the first element in a list (same as car in lisp) +head (x:xs) = x + +tail :: [a] -> [a] -- removes the first element from a list (same as cdr) +tail (x:xs) = xs + +null :: [a] -> Bool +null [] = True +null (x:xs) = False + +cons :: a -> [a] -> [a] +cons x xs = x:xs + +nil :: [a] +nil = [] + +-- Length could be defined using these functions too. This is +-- not good Haskell style but does illustrate these other list functions. +-- The if - then - else will be discussed later. Haskell programmers feel +-- that the pattern matching style, as used in the previous version of +-- length, is more natural and readable. + +length' :: [a] -> Int -- Note that ' can be part of a name +length' x = if null x then 0 else 1 + length' (tail x) + +-- A test case for length', cons, and nil + +e1 = length' (cons 1 (cons 2 nil)) + +-- We haven't said anything about errors yet. Each of the following +-- examples illustrates a potential runtime or compile time error. The +-- compile time error is commented out so that other examples will compile; +-- you can uncomment them and see what happens. + +-- e2 = cons True False -- Why is this not possible in Haskell? +e3 = tail (tail ['a']) -- What happens if you evaluate this? +e4 = [] -- This is especially mysterious! + +-- This last example, e4, is something hard to explain but is often +-- encountered early by novices. We haven't explained yet how the system +-- prints out the expressions you type in - this will wait until later. +-- However, the problem here is that e4 has the type [a]. The printer for +-- the list datatype is complaining that it needs to know a specific type +-- for the list elements even though the list has no elements! This can +-- be avoided by giving e4 a type such as [Int]. (To further confuse you, +-- try giving e4 the type [Char] and see what happens.) + +-- Page 3 Section 2.2 + +-- Section 2.2 User-Defined Types + +module Test(Bool) where + +-- The type Bool is already defined in the Prelude so there is no +-- need to define it here. + +data Color = Red | Green | Blue | Indigo | Violet deriving Text +-- The `deriving Text' is necessary if you want to print a Color value. + +-- You can now evaluate these expressions. +e1 :: Color +e1 = Red +e2 :: [Color] +e2 = [Red,Blue] + +-- It is very important to keep the expression language and the type +-- language in Haskell separated. The data declaration above defines +-- the type constructor Color. This is a nullary constructor: it takes no +-- arguments. Color is found ONLY in the type language - it can not be +-- part of an expression. e1 = Color is meaningless. (Actually, Color could +-- be both a data constructor and a type constructor but we'll ignore this +-- possibility for now). On the other hand, Red, Blue, and so on are +-- (nullary) data constructors. They can appear in expressions and +-- in patterns (described later). The declaration e1 :: Blue would also +-- be meaningless. Data constructors can be defined ONLY in a data +-- declaration. + +-- In the next example, Point is a type constructor and Pt is a data +-- constructor. Point takes one argument and Pt takes two. A data constructor +-- like Pt is really just an ordinary function except that it can be used in +-- a pattern. Type signatures can not be supplied directly for data +-- constructors; their typing is completely defined by the data declaration. +-- However, data constructors have a signature just like any variable: +-- Pt :: a -> a -> Point a -- Not valid Haskell syntax +-- That is, Pt is a function which takes two arguments with the same +-- arbitrary type and returns a value containing the two argument values. + +data Point a = Pt a a deriving Text + +e3 :: Point Float +e3 = Pt 2.0 3.0 +e4 :: Point Char +e4 = Pt 'a' 'b' +e5 :: Point (Point Int) +e5 = Pt (Pt 1 2) (Pt 3 4) +-- e6 = Pt 'a' True -- This is a typing error + +-- The individual components of a point do not have names. +-- Let's jump ahead a little so that we can write functions using these +-- data types. Data constructors (Red, Blue, ..., and Pt) can be used in +-- patterns. When more than one equation is used to define a function, +-- pattern matching occurs top down. + +-- A function to remove red from a list of colors. + +removeRed :: [Color] -> [Color] +removeRed [] = [] +removeRed (Red:cs) = removeRed cs +removeRed (c:cs) = c : removeRed cs -- c cannot be Red at this point + +e7 :: [Color] +e7 = removeRed [Blue,Red,Green,Red] + +-- Pattern matching is capable of testing equality with a specific color. + +-- All equations defining a function must share a common type. A +-- definition such as: +-- foo Red = 1 +-- foo (Pt x y) = x +-- would result in a type error since the argument to foo cannot be both a +-- Color and a Point. Similarly, the right hand sides must also share a +-- common type; a definition such as +-- foo Red = Blue +-- foo Blue = Pt Red Red +-- would also result in a type error. + +-- Here's a couple of functions defined on points. + +dist :: Point Float -> Point Float -> Float +dist (Pt x1 y1) (Pt x2 y2) = sqrt ((x1-x2)^2 + (y1-y2)^2) + +midpoint :: Point Float -> Point Float -> Point Float +midpoint (Pt x1 y1) (Pt x2 y2) = Pt ((x1+x2)/2) ((y1+y2)/2) + +p1 :: Point Float +p1 = Pt 1.0 1.0 +p2 :: Point Float +p2 = Pt 2.0 2.0 + +e8 :: Float +e8 = dist p1 p2 +e9 :: Point Float +e9 = midpoint p1 p2 + +-- The only way to take apart a point is to pattern match. +-- That is, the two values which constitute a point must be extracted +-- by matching a pattern containing the Pt data constructor. Much +-- more will be said about pattern matching later. + +-- Haskell prints values in the same syntax used in expressions. Thus +-- Pt 1 2 would print as Pt 1 2 (of course, Pt 1 (1+1) would also print +-- as Pt 1 2). + +-- Page 4 Section 2.3 + +-- Section 2.3 Recursive Types + +module Test where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +-- The following typings are implied by this declaration. As before, +-- this is not valid Haskell syntax. +-- Leaf :: a -> Tree a +-- Branch :: Tree a -> Tree a -> Tree a + +fringe :: Tree a -> [a] +fringe (Leaf x) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +-- The following trees can be used to test functions: + +tree1 :: Tree Int +tree1 = Branch (Leaf 1) (Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 4)) +tree2 :: Tree Int +tree2 = Branch (Branch (Leaf 3) (Leaf 1)) (Branch (Leaf 4) (Leaf 1)) +tree3 :: Tree Int +tree3 = Branch tree1 tree2 + +-- Try evaluating `fringe tree1' and others. + +-- Here's another tree function: + +twist :: Tree a -> Tree a +twist (Branch left right) = Branch right left +twist x = x -- This equation only applies to leaves + +-- Here's a function which compares two trees to see if they have the +-- same shape. Note the signature: the two trees need not contain the +-- same type of values. + +sameShape :: Tree a -> Tree b -> Bool +sameShape (Leaf x) (Leaf y) = True +sameShape (Branch l1 r1) (Branch l2 r2) = sameShape l1 l2 && sameShape r1 r2 +sameShape x y = False -- One is a branch, the other is a leaf + +-- The && function is a boolean AND function. + +-- The entire pattern on the left hand side must match in order for the +-- right hand side to be evaluated. The first clause requires both +-- arguments to be a leaf' otherwise the next equation is tested. +-- The last clause will always match: the final x and y match both +-- leaves and branches. + +-- This compares a tree of integers to a tree of booleans. +e1 = sameShape tree1 (Branch (Leaf True) (Leaf False)) + +-- Page 5 Sections 2.4, 2.5, 2.6 + +-- Section 2.4 Type Synonyms + +module Test(Bool) where + +-- Since type synonyms are part of the type language only, it's hard to +-- write a program which shows what they do. Essentially, they are like +-- macros for the type language. They can be used interchangably with their +-- definition: + +e1 :: String +e1 = "abc" +e2 :: [Char] -- No different than String +e2 = e1 + +-- In the written tutorial the declaration of `Addr' is a data type +-- declaration, not a synonym declaration. This shows that the data +-- type declaration as well as a signature can reference a synonym. + +-- Section 2.5 Built-in Types + +-- Tuples are an easy way of grouping a set of data values. Here are +-- a few tuples. Note the consistancy in notation between the values and +-- types. + +e3 :: (Bool,Int) +e3 = (True,4) +e4 :: (Char,[Int],Char) +e4 = ('a',[1,2,3],'b') + +-- Here's a function which returns the second component of a 3 tuple. +second :: (a,b,c) -> b +second (a,b,c) = b + +-- Try out `second e3' and `second e4' - what happens? +-- Each different size of tuple is a completely distinct type. There is +-- no general way to append two arbitrary tuples or randomly select the +-- i'th component of an arbitrary tuple. Here's a function built using +-- 2-tuples to represent intervals. + +-- Use a type synonym to represent homogenous 2 tuples +type Interval a = (a,a) + +containsInterval :: Interval Int -> Interval Int -> Bool +containsInterval (xmin,xmax) (ymin,ymax) = xmin <= ymin && xmax >= ymax + +p1 :: Interval Int +p1 = (2,3) +p2 :: Interval Int +p2 = (1,4) + +e5 = containsInterval p1 p2 +e6 = containsInterval p2 p1 + +-- Here's a type declaration for a type isomorphic to lists: + +data List a = Nil | Cons a (List a) deriving Text + +-- Except for the notation, this is completely equivalent to ordinary lists +-- in Haskell. + +length' :: List a -> Int +length' Nil = 0 +length' (Cons x y) = 1 + length' y + +e7 = length' (Cons 'a' (Cons 'b' (Cons 'c' Nil))) + +-- It's hard to demonstrate much about the `non-specialness' of built-in +-- types. However, here is a brief summary: + +-- Numbers and characters, such as 1, 2.2, or 'a', are the same as nullary +-- type constructors. + +-- Lists have a special type constructor, [a] instead of List a, and +-- an odd looking data constructor, []. The other data constructor, :, is +-- not `unusual', syntactically speaking. The notation [x,y] is just +-- syntax for x:y:[] and "abc" for 'a' : 'b' : 'c' : []. + +-- Tuples use a special syntax. In a type expression, a 2 tuple containing +-- types a and be would be written (a,b) instead of using a prefix type +-- constructor such as Tuple2 a b. This same notation is used to build +-- tuple values: (1,2) would construct a 2 tuple containing the values 1 and 2. + + +-- Page 6 Sections 2.5.1, 2.5.2 + +module Test(Bool) where + +-- Section 2.5.1 List Comprehensions and Arithmetic Sequences + +-- Warning: brackets in Haskell are used in three different types +-- of expressions: lists, as in [a,b,c], sequences (distinguished by +-- the ..), as in [1..2], and list comprehensions (distinguished by the +-- bar: |), as in [x+1 | x <- xs, x > 1]. + +-- Before list comprehensions, let's start out with sequences: + +e1 :: [Int] +e1 = [1..10] -- Step is 1 +e2 :: [Int] +e2 = [1,3..10] -- Step is 3 - 1 +e3 :: [Int] +e3 = [1,-1..-10] +e4 :: [Char] +e4 = ['a'..'z'] -- This works on chars too + +-- We'll avoid infinite sequences like [1..] for now. If you print one, +-- use C-c i to interrupt the Haskell program. + +-- List comprehensions are very similar to nested loops. They return a +-- list of values generated by the expression inside the loop. The filter +-- expressions are similar to conditionals in the loop. + +-- This function does nothing at all! It just scans through a list and +-- copies it into a new one. + +doNothing :: [a] -> [a] +doNothing l = [x | x <- l] + +-- Adding a filter to the previous function allows only selected elements to +-- be generated. This is similar to what is done in quicksort. + +positives :: [Int] -> [Int] +positives l = [x | x <- l, x > 0] + +e5 = positives [2,-4,5,6,-5,3] + +-- Now the full quicksort function. + +quicksort :: [Char] -> [Char] -- Use Char just to be different! +quicksort [] = [] +quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++ + [x] ++ + quicksort [y | y <- xs, y > x] + +e6 = quicksort "Why use Haskell?" + +-- Now for some nested loops. Each generator, <-, adds another level of +-- nesting to the loop. Note that the variable introduced by each generator +-- can be used in each following generator; all variables can be used in the +-- generated expression: + +e7 :: [(Int,Int)] +e7 = [(x,y) | x <- [1..5], y <- [x..5]] + +-- Now let's add some guards: (the /= function is `not equal') + +e8 :: [(Int,Int)] +e8 = [(x,y) | x <- [1..7], x /= 5, y <- [x..8] , x*y /= 12] + +-- This is the same as the loop: (going to a psuedo Algol notation) +-- for x := 1 to 7 do +-- if x <> 5 then +-- for y := x to 8 do +-- if x*y <> 12 +-- generate (x,y) + +-- Section 2.5.2 Strings + +e9 = "hello" ++ " world" + +-- Page 7 Sections 3, 3.1 + +module Test(Bool) where +import Prelude hiding (map) + +-- Section 3 Functions + +add :: Int -> Int -> Int +add x y = x+y + +e1 :: Int +e1 = add 1 2 + +-- This Int -> Int is the latter part of the signature of add: +-- add :: Int -> (Int -> Int) + +succ :: Int -> Int +succ = add 1 + +e2 :: Int +e2 = succ 3 + +map :: (a->b) -> [a] -> [b] +map f [] = [] +map f (x:xs) = f x : (map f xs) + +e3 :: [Int] +e3 = map (add 1) [1,2,3] +-- This next definition is the equivalent to e3 +e4 :: [Int] +e4 = map succ [1,2,3] + +-- Heres a more complex example. Define flist to be a list of functions: +flist :: [Int -> Int] +flist = map add [1,2,3] +-- This returns a list of functions which add 1, 2, or 3 to their input. +-- Warning: Haskell should print flist as something like +-- [<<function>>,<<function>>,<<function>>] + + +-- Now, define a function which takes a function and returns its value +-- when applied to the constant 1: +applyTo1 :: (Int -> a) -> a +applyTo1 f = f 1 + +e5 :: [Int] +e5 = map applyTo1 flist -- Apply each function in flist to 1 + +-- If you want to look at how the type inference works, figure out how +-- the signatures of map, applyTo1, and flist combine to yield [Int]. + +-- Section 3.1 Lambda Abstractions + +-- The symbol \ is like `lambda' in lisp or scheme. + +-- Anonymous functions are written as \ arg1 arg2 ... argn -> body +-- Instead of naming every function, you can code it inline with this +-- notation: + +e6 = map (\f -> f 1) flist + +-- Be careful with the syntax here. \x->\y->x+y parses as +-- \ x ->\ y -> x + y. The ->\ is all one token. Use spaces!! + +-- This is identical to e5 except that the applyTo1 function has no name. + +-- Function arguments on the left of an = are the same as lambda on the +-- right: + +add' = \x y -> x+y -- identical to add +succ' = \x -> x+1 -- identical to succ + +-- As with ordinary function, the parameters to anonymous functions +-- can be patterns: + +e7 :: [Int] +e7 = map (\(x,y) -> x+y) [(1,2),(3,4),(5,6)] + +-- Functions defined by more than one equation, like map, cannot +-- be converted to anonymous lambda functions quite as easily - a case +-- statement is also required. This is discussed later. + +-- Page 8 Sections 3.2, 3.2.1, 3.2.2 + +module Test(Bool) where + +import Prelude hiding ((++),(.)) + +-- Section 3.2 Infix operators + +-- Haskell has both identifiers, like x, and operators, like +. +-- These are just two different types of syntax for variables. +-- However, operators are by default used in infix notation. + +-- Briefly, identifiers begin with a letter and may have numbers, _, and ' +-- in them: x, xyz123, x'', xYz'_12a. The case of the first letter +-- distinguishes variables from data constructors (or type variables from +-- type constructors). An operator is a string of symbols, where +-- :!#$%&*+./<=>?@\^| are all symbols. If the first character is : then +-- the operator is a data constructor; otherwise it is an ordinary +-- variable operator. The - and ~ characters may start a symbol but cannot +-- be used after the first character. This allows a*-b to parse as +-- a * - b instead of a *- b. + +-- Operators can be converted to identifiers by enclosing them in parens. +-- This is required in signature declarations. Operators can be defined +-- as well as used in the infix style: + +(++) :: [a] -> [a] -> [a] +[] ++ y = y +(x:xs) ++ y = x : (xs ++ y) + +-- Table 2 (Page 54) of the report is invaluable for sorting out the +-- precedences of the many predefined infix operators. + +e1 = "Foo" ++ "Bar" + +-- This is the same function without operator syntax +appendList :: [a] -> [a] -> [a] +appendList [] y = y +appendList (x:xs) y = x : appendList xs y + +(.) :: (b -> c) -> (a -> b) -> (a -> c) +f . g = \x -> f (g x) + +add1 :: Int -> Int +add1 x = x+1 + +e2 = (add1 . add1) 3 + +-- Section 3.2.1 Sections + +-- Sections are a way of creating unary functions from infix binary +-- functions. When a parenthesized expression starts or ends in an +-- operator, it is a section. Another definition of add1: + +add1' :: Int -> Int +add1' = (+ 1) + +e3 = add1' 4 + +-- Here are a few section examples: + +e4 = map (++ "abc") ["x","y","z"] + +e5 = map ("abc" ++) ["x","y","z"] + + +-- Section 3.2.2 Fixity Declarations + +-- We'll avoid any demonstration of fixity declarations. The Prelude +-- contains numerous examples. + +-- Page 9 Sections 3.3, 3.4, 3.5 +module Test(Bool) where + +import Prelude hiding (take,zip) + +-- Section 3.3 Functions are Non-strict + +-- Observing lazy evaluation can present difficulties. The essential +-- question is `does an expression get evaluated?'. While in theory using a +-- non-terminating computation is the way evaluation issues are examined, +-- we need a more practical approach. The `error' function serves as +-- a bottom value. Evaluating this function prints an error message and +-- halts execution. + +bot = error "Evaluating Bottom" + +e1 :: Bool -- This can be any type at all! +e1 = bot -- evaluate this and see what happens. + +const1 :: a -> Int +const1 x = 1 + +e2 :: Int +e2 = const1 bot -- The bottom is not needed and will thus not be evaluated. + +-- Section 3.4 "Infinite" Data Structures + +-- Data structures are constructed lazily. A constructor like : will not +-- evaluate its arguments until they are demanded. All demands arise from +-- the need to print the result of the computation -- components not needed +-- to compute the printed result will not be evaluated. + +list1 :: [Int] +list1 = (1:bot) + +e3 = head list1 -- doesnt evaluate bot +e4 = tail list1 -- does evaluate bot + +-- Some infinite data structures. Don't print these! If you do, you will +-- need to interrupt the system (C-c i) or kill the Haskell process. + +ones :: [Int] +ones = 1 : ones + +numsFrom :: Int -> [Int] +numsFrom n = n : numsFrom (n+1) + +-- An alternate numsFrom using series notation: + +numsFrom' :: Int -> [Int] +numsFrom' n = [n..] + +squares :: [Int] +squares = map (^2) (numsFrom 0) + +-- Before we start printing anything, we need a function to truncate these +-- infinite lists down to a more manageable size. The `take' function +-- extracts the first k elements of a list: + +take :: Int -> [a] -> [a] +take 0 x = [] -- two base cases: k = 0 +take k [] = [] -- or the list is empty +take k (x:xs) = x : take (k-1) xs + +-- now some printable lists: + +e5 :: [Int] +e5 = take 5 ones + +e6 :: [Int] +e6 = take 5 (numsFrom 10) + +e7 :: [Int] +e7 = take 5 (numsFrom' 0) + +e8 :: [Int] +e8 = take 5 squares + +-- zip is a function which turns two lists into a list of 2 tuples. If +-- the lists are of differing sizes, the result is as long as the +-- shortest list. + +zip (x:xs) (y:ys) = (x,y) : zip xs ys +zip xs ys = [] -- one of the lists is [] + +e9 :: [(Int,Int)] +e9 = zip [1,2,3] [4,5,6] + +e10 :: [(Int,Int)] +e10 = zip [1,2,3] ones + +fib :: [Int] +fib = 1 : 1 : [x+y | (x,y) <- zip fib (tail fib)] + +e11 = take 5 fib + +-- Let's do this without the list comprehension: + +fib' :: [Int] +fib' = 1 : 1 : map (\(x,y) -> x+y) (zip fib (tail fib)) + +-- This could be written even more cleanly using a map function which +-- maps a binary function over two lists at once. This is in the +-- Prelude and is called zipWith. + +fib'' :: [Int] +fib'' = 1 : 1 : zipWith (+) fib (tail fib) + +-- For more examples using infinite structures look in the demo files +-- that come with Yale Haskell. Both the pascal program and the +-- primes program use infinite lists. + +-- Section 3.5 The Error Function + +-- Too late - we already used it! + + +-- Page 10 Sections 4, 4.1, 4.2 + +module Test(Bool) where + +import Prelude hiding (take,(^)) + +-- Section 4 Case Expressions and Pattern Matching + +-- Now for details of pattern matching. We use [Int] instead of [a] +-- since the only value of type [a] is []. + +contrived :: ([Int], Char, (Int, Float), String, Bool) -> Bool +contrived ([], 'b', (1, 2.0), "hi", True) = False +contrived x = True -- add a second equation to avoid runtime errors + +e1 :: Bool +e1 = contrived ([], 'b', (1, 2.0), "hi", True) +e2 :: Bool +e2 = contrived ([1], 'b', (1, 2.0), "hi", True) + +-- Contrived just tests its input against a big constant. + +-- Linearity in pattern matching implies that patterns can only compare +-- values with constants. The following is not valid Haskell: + +-- member x [] = False +-- member x (x:ys) = True -- Invalid since x appears twice +-- member x (y:ys) = member x ys + +f :: [a] -> [a] +f s@(x:xs) = x:s +f _ = [] + +e3 = f "abc" + +-- Another use of _: + +middle :: (a,b,c) -> b +middle (_,x,_) = x + +e4 :: Char +e4 = middle (True, 'a', "123") + +(^) :: Int -> Int -> Int +x ^ 0 = 1 +x ^ (n+1) = x*(x^n) + +e5 :: Int +e5 = 3^3 +e6 :: Int +e6 = 4^(-2) -- Notice the behavior of the + pattern on this one + +-- Section 4.1 Pattern Matching Semantics + +-- Here's an extended example to illustrate the left -> right, top -> bottom +-- semantics of pattern matching. + +foo :: (Int,[Int],Int) -> Int +foo (1,[2],3) = 1 +foo (2,(3:_),3) = 2 +foo (1,_,3) = 3 +foo _ = 4 + +bot = error "Bottom Evaluated" + +e7 = foo (1,[],3) +e8 = foo (1,bot,3) +e9 = foo (1,1:bot,3) +e10 = foo (2,bot,2) +e11 = foo (3,bot,bot) + +-- Now add some guards: + +sign :: Int -> Int +sign x | x > 0 = 1 + | x == 0 = 0 + | x < 0 = -1 + +e12 = sign 3 + +-- The last guard is often `True' to catch all other cases. The identifier +-- `otherwise' is defined as True for use in guards: + +max' :: Int -> Int -> Int +max' x y | x > y = x + | otherwise = y + +-- Guards can refer to any variables bound by pattern matching. When +-- no guard is true, pattern matching resumes at the next equation. Guards +-- may also refer to values bound in an associated where declaration. + + +inOrder :: [Int] -> Bool +inOrder (x1:x2:xs) | x1 <= x2 = True +inOrder _ = False + +e13 = inOrder [1,2,3] +e14 = inOrder [2,1] + +-- Section 4.2 An Example + +take :: Int -> [a] -> [a] +take 0 _ = [] +take _ [] = [] +take (n+1) (x:xs) = x:take n xs + +take' :: Int -> [a] -> [a] +take' _ [] = [] +take' 0 _ = [] +take' (n+1) (x:xs) = x:take' n xs + +e15, e16, e17, e18 :: [Int] +e15 = take 0 bot +e16 = take' 0 bot +e17 = take bot [] +e18 = take' bot [] + +-- Page 11 Sections 4.3, 4.4, 4.5, 4.6 + +module Test(Bool) where + +-- import Prelude hiding (take,Request(..),Response(..)) -- Standard Haskell +import Prelude hiding (take) -- Y2.0-b4 only + +-- Section 4.3 Case Expressions + +-- The function take using a case statement instead of multiple equations + +take :: Int -> [a] -> [a] +take m ys = case (m,ys) of + (0 ,_) -> [] + (_ ,[]) -> [] + (n+1,x:xs) -> x : take n xs + +-- The function take using if then else. We can also eliminate the n+k +-- pattern just for fun. The original version of take is much easier to read! + +take' :: Int -> [a] -> [a] +take' m ys = if m == 0 then [] else + if null ys then [] else + if m > 0 then head ys : take (m-1) (tail ys) + else error "m < 0" + +-- Section 4.4 Lazy Patterns + +-- Before the client-server example, here is a contrived example of lazy +-- patterns. The first version will fail to pattern match whenever the +-- the first argument is []. The second version will always pattern +-- match initially but x will fail if used when the list is []. + +nonlazy :: [Int] -> Bool -> [Int] +nonlazy (x:xs) isNull = if isNull then [] else [x] + +e1 = nonlazy [1,2] False +e2 = nonlazy [] True +e3 = nonlazy [] False + +-- This version will never fail the initial pattern match +lazy :: [Int] -> Bool -> [Int] +lazy ~(x:xs) isNull = if isNull then [] else [x] + +e4 = lazy [1,2] False +e5 = lazy [] True +e6 = lazy [] False + +-- The server - client example is a little hard to demonstrate. We'll avoid +-- the initial version which loops. Here is the version with irrefutable +-- patterns. + +type Response = Int +type Request = Int + +client :: Request -> [Response] -> [Request] +client init ~(resp:resps) = init : client (next resp) resps + +server :: [Request] -> [Response] +server (req : reqs) = process req : server reqs + +-- Next maps the response from the previous request onto the next request +next :: Response -> Request +next resp = resp + +-- Process maps a request to a response +process :: Request -> Response +process req = req+1 + +requests :: [Request] +requests = client 0 responses + +responses :: [Response] +responses = server requests + +e7 = take 5 responses + +-- The lists of requests and responses are infinite - there is no need to +-- check for [] in this program. These lists correspond to streams in other +-- languages. + +-- Here is fib again: + +fib :: [Int] +fib@(1:tfib) = 1 : 1 : [ a+b | (a,b) <- zip fib tfib] + +e8 = take 10 fib + +-- Section 4.5 Lexical Scoping and Nested Forms + +-- One thing that is important to note is that the order of the +-- definitions in a program, let expression, or where clauses is +-- completely arbitrary. Definitions can be arranged 'top down' +-- or `bottom up' without changing the program. + +e9 = let y = 2 :: Float + f x = (x+y)/y + in f 1 + f 2 + +f :: Int -> Int -> String +f x y | y > z = "y > x^2" + | y == z = "y = x^2" + | y < z = "y < x^2" + where + z = x*x + +e10 = f 2 5 +e11 = f 2 4 + +-- Section 4.6 Layout + +-- There's nothing much to demonstrate here. We have been using layout all +-- through the tutorial. The main thing is to be careful line up the +-- first character of each definition. For example, if you +-- change the indentation of the definition of f in e9 you will get a +-- parse error. + +-- Page 12 Section 5 +module Test(Bool) where + +import Prelude hiding (elem) + +-- Section 5 Type Classes + +-- Names in the basic class structure of Haskell cannot be hidden (they are +-- in PreludeCore) so we have to modify the names used in the tutorial. + +-- Here is a new Eq class: + +class Eq' a where + eq :: a -> a -> Bool + +-- Now we can define elem using eq from above: + +elem :: (Eq' a) => a -> [a] -> Bool +x `elem` [] = False +x `elem` (y:ys) = x `eq` y || x `elem` ys + +-- Before this is of any use, we need to admit some types to Eq' + +instance Eq' Int where + x `eq` y = abs (x-y) < 3 -- Let's make this `nearly equal' just for fun + +instance Eq' Float where + x `eq` y = abs (x-y) < 0.1 + +list1 :: [Int] +list1 = [1,5,9,23] + +list2 :: [Float] +list2 = [0.2,5.6,33,12.34] + +e1 = 2 `elem` list1 +e2 = 100 `elem` list1 +e3 = 0.22 `elem` list2 + +-- Watch out! Integers in Haskell are overloaded - without a type signature +-- to designate an integer as an Int, expressions like 3 `eq` 3 will be +-- ambiguous. See 5.5.4 about this problem. + +-- Now to add the tree type: + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +instance (Eq' a) => Eq' (Tree a) where + (Leaf a) `eq` (Leaf b) = a `eq` b + (Branch l1 r1) `eq` (Branch l2 r2) = (l1 `eq` l2) && (r1 `eq` r2) + _ `eq` _ = False + +tree1,tree2 :: Tree Int +tree1 = Branch (Leaf 1) (Leaf 2) +tree2 = Branch (Leaf 2) (Leaf 1) + +e4 = tree1 `eq` tree2 + +-- Now make a new class with Eq' as a super class: + +class (Eq' a) => Ord' a where + lt,le :: a -> a -> Bool -- lt and le are operators in Ord' + x `le` y = x `eq` y || x `lt` y -- This is a default for le + +-- The typing of lt & le is +-- le,lt :: (Ord' a) => a -> a -> Bool +-- This is identical to +-- le,lt :: (Eq' a,Ord' a) => a -> a -> Bool + +-- Make Int an instance of Ord +instance Ord' Int where + x `lt` y = x < y+1 + +i :: Int -- Avoid ambiguity +i = 3 +e5 :: Bool +e5 = i `lt` i + +-- Some constraints on instance declarations: +-- A program can never have more than one instance declaration for +-- a given combination of data type and class. +-- If a type is declared to be a member of a class, it must also be +-- declared in all superclasses of that class. +-- An instance declaration does not need to supply a method for every +-- operator in the class. When a method is not supplied in an +-- instance declaration and no default is present in the class +-- declaration, a runtime error occurs if the method is invoked. +-- You must supply the correct context for an instance declaration -- +-- this context is not inferred automatically. + +-- Section 5.1 Equality and Ordered Classes +-- Section 5.2 Enumeration and Index Classes + +-- No examples are provided for 5.1 or 5.2. The standard Prelude contains +-- many instance declarations which illustrate the Eq, Ord, and Enum classes. + +-- Page 13 Section 5.3 + +module Test(Bool) where + +-- Section 5.3 Text and Binary Classes + +-- This is the slow showTree. The `show' function is part of the +-- Text class and works with all the built-in types. The context `Text a' +-- arises from the call to show for leaf values. + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +showTree :: (Text a) => Tree a -> String +showTree (Leaf x) = show x +showTree (Branch l r) = "<" ++ showTree l ++ "|" ++ showTree r ++ ">" + +tree1 :: Tree Int +tree1 = Branch (Leaf 1) (Branch (Leaf 3) (Leaf 6)) + +e1 = showTree tree1 + +-- Now the improved showTree; shows is already defined for all +-- built in types. + +showsTree :: Text a => Tree a -> String -> String +showsTree (Leaf x) s = shows x s +showsTree (Branch l r) s = '<' : showsTree l ('|' : showsTree r ('>' : s)) + +e2 = showsTree tree1 "" + +-- The final polished version. ShowS is predefined in the Prelude so we +-- don't need it here. + + +showsTree' :: Text a => Tree a -> ShowS +showsTree' (Leaf x) = shows x +showsTree' (Branch l r) = ('<' :) . showsTree' l . ('|' :) . + showsTree' r . ('>' :) + +e3 = showsTree' tree1 "" + + +-- Page 14 This page break is just to keep recompilation from getting too +-- long. The compiler takes a little longer to compile this +-- page than other pages. + +module Test(Bool) where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +-- Now for the reading function. Again, ReadS is predefined and reads works +-- for all built-in types. The generators in the list comprehensions are +-- patterns: p <- l binds pattern p to successive elements of l which match +-- p. Elements not matching p are skipped. + +readsTree :: (Text a) => ReadS (Tree a) +readsTree ('<':s) = [(Branch l r, u) | (l, '|':t) <- readsTree s, + (r, '>':u) <- readsTree t ] +readsTree s = [(Leaf x,t) | (x,t) <- reads s] + +e4 :: [(Int,String)] +e4 = reads "5 golden rings" + +e5 :: [(Tree Int,String)] +e5 = readsTree "<1|<2|3>>" +e6 :: [(Tree Int,String)] +e6 = readsTree "<1|2" +e7 :: [(Tree Int,String)] +e7 = readsTree "<1|<<2|3>|<4|5>>> junk at end" + +-- Before we do the next readTree, let's play with the lex function. + +e8 :: [(String,String)] +e8 = lex "foo bar bletch" + +-- Here's a function to completely lex a string. This does not handle +-- lexical ambiguity - lex would return more than one possible lexeme +-- when an ambiguity is encountered and the patterns used here would not +-- match. + +lexAll :: String -> [String] +lexAll s = case lex s of + [("",_)] -> [] -- lex returns an empty token if none is found + [(token,rest)] -> token : lexAll rest + +e9 = lexAll "lexAll :: String -> [String]" +e10 = lexAll "<1|<a|3>>" + +-- Finally, the `hard core' reader. This is not sensitive to +-- white space as were the previous versions. + + +readsTree' :: (Text a) => ReadS (Tree a) +readsTree' s = [(Branch l r, x) | ("<", t) <- lex s, + (l, u) <- readsTree' t, + ("|", v) <- lex u, + (r, w) <- readsTree' v, + (">", x) <- lex w ] + ++ + [(Leaf x, t) | (x, t) <- reads s] + +-- When testing this program, you must make sure the input conforms to +-- Haskell lexical syntax. If you remove spaces between | and < or +-- > and > they will lex as a single token. + +e11 :: [(Tree Int,String)] +e11 = readsTree' "<1 | <2 | 3> >" +e12 :: [(Tree Bool,String)] +e12 = readsTree' "<True|False>" + +-- Finally, here is a simple version of read for trees only: + +read' :: (Text a) => String -> (Tree a) +read' s = case (readsTree' s) of + [(tree,"")] -> tree -- Only one parse, no junk at end + [] -> error "Couldn't parse tree" + [_] -> error "Crud after the tree" -- unread chars at end + _ -> error "Ambiguous parse of tree" + +e13 :: Tree Int +e13 = read' "foo" +e14 :: Tree Int +e14 = read' "< 1 | < 2 | 3 > >" +e15 :: Tree Int +e15 = read' "3 xxx" + +-- Page 15 Section 5.4 + +module Test(Bool) where + +-- Section 5.4 Derived Instances + +-- We have actually been using the derived Text instances all along for +-- printing out trees and other structures we have defined. The code +-- in the tutorial for the Eq and Ord instance of Tree is created +-- implicitly by the deriving clause so there is no need to write it +-- here. + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Eq,Ord,Text) + +-- Now we can fire up both Eq and Ord functions for trees: + +tree1, tree2, tree3, tree4 :: Tree Int +tree1 = Branch (Leaf 1) (Leaf 3) +tree2 = Branch (Leaf 1) (Leaf 5) +tree3 = Leaf 4 +tree4 = Branch (Branch (Leaf 4) (Leaf 3)) (Leaf 5) + +e1 = tree1 == tree1 +e2 = tree1 == tree2 +e3 = tree1 < tree2 + +quicksort :: Ord a => [a] -> [a] +quicksort [] = [] +quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++ + [x] ++ + quicksort [y | y <- xs, y > x] + +e4 = quicksort [tree1,tree2,tree3,tree4] + +-- Now for Enum: + +data Day = Sunday | Monday | Tuesday | Wednesday | Thursday | + Friday | Saturday deriving (Text,Eq,Ord,Enum) + +e5 = quicksort [Monday,Saturday,Friday,Sunday] +e6 = [Wednesday .. Friday] +e7 = [Monday, Wednesday ..] +e8 = [Saturday, Friday ..] + + +-- Page 16 Sections 5.5, 5.5.1, 5.5.2, 5.5.3 + +module Test(Bool) where + +-- Section 5.5 Numbers +-- Section 5.5.1 Numeric Class Structure +-- Section 5.5.2 Constructed Numbers + +-- Here's a brief summary of Haskell numeric classes. + +-- Class Num +-- Most general numeric class. Has addition, subtraction, multiplication. +-- Integers can be coerced to any instance of Num with fromInteger. +-- All integer constants are in this class. +-- Instances: Int, Integer, Float, Double, Ratio a, Complex a + +-- Class Real +-- This class contains ordered numbers which can be converted to +-- rationals. +-- Instances: Int, Integer, Float, Double, Ratio a + +-- Class Integral +-- This class deals with integer division. All values in Integral can +-- be mapped onto Integer. +-- Instances: Int, Integer + +-- Class Fractional +-- These are numbers which can be divided. Any rational number can +-- be converted to a fractional. Floating point constants are in +-- this class: 1.2 would be 12/10. +-- Instances: Float, Double, Ratio a + +-- Class Floating +-- This class contains all the standard floating point functions such +-- as sqrt and sin. +-- Instances: Float, Double, Complex a + +-- Class RealFrac +-- These values can be rounded to integers and approximated by rationals. +-- Instances: Float, Double, Ratio a + +-- Class RealFloat +-- These are floating point numbers constructed from a fixed precision +-- mantissa and exponent. +-- Instances: Float, Double + +-- There are only a few sensible combinations of the constructed numerics +-- with built-in types: +-- Ratio Integer (same as Rational): arbitrary precision rationals +-- Ratio Int: limited precision rationals +-- Complex Float: complex numbers with standard precision components +-- Complex Double: complex numbers with double precision components + + +-- The following function works for arbitrary numerics: + +fact :: (Num a) => a -> a +fact 0 = 1 +fact n = n*(fact (n-1)) + +-- Note the behavior when applied to different types of numbers: + +e1 :: Int +e1 = fact 6 +e2 :: Int +e2 = fact 20 -- Yale Haskell may not handle overflow gracefully! +e3 :: Integer +e3 = fact 20 +e4 :: Rational +e4 = fact 6 +e5 :: Float +e5 = fact 6 +e6 :: Complex Float +e6 = fact 6 + +-- Be careful: values like `fact 1.5' will loop! + +-- As a practical matter, Int operations are much faster than Integer +-- operations. Also, overloaded functions can be much slower than non- +-- overloaded functions. Giving a function like fact a precise typing: + +-- fact :: Int -> Int + +-- will yield much faster code. + +-- In general, numeric expressions work as expected. Literals are +-- a little tricky - they are coerced to the appropriate value. A +-- constant like 1 can be used as ANY numeric type. + +e7 :: Float +e7 = sqrt 2 +e8 :: Rational +e8 = ((4%5) * (1%2)) / (3%4) +e9 :: Rational +e9 = 2.2 * (3%11) - 1 +e10 :: Complex Float +e10 = (2 * (3:+3)) / (1.1:+2.0 - 1) +e11 :: Complex Float +e11 = sqrt (-1) +e12 :: Integer +e12 = numerator (4%2) +e13 :: Complex Float +e13 = conjugate (4:+5.2) + +-- A function using pattern matching on complex numbers: + +mag :: (RealFloat a) => Complex a -> a +mag (a:+b) = sqrt (a^2 + b^2) + +e14 :: Float +e14 = mag (1:+1) + +-- Section 5.5.3 Numeric Coercions and Overloaded Literals + +-- The Haskell type system does NOT implicitly coerce values between +-- the different numeric types! Although overloaded constants are +-- coerced when the overloading is resolved, no implicit coercion goes +-- on when values of different types are mixed. For example: + +f :: Float +f = 1.1 +i1 :: Int +i1 = 1 +i2 :: Integer +i2 = 2 + +-- All of these expressions would result in a type error (try them!): + +-- g = i1 + f +-- h = i1 + i2 +-- i3 :: Int +-- i3 = i2 + +-- Appropriate coercions must be introduced by the user to allow +-- the mixing of types in arithmetic expressions. + +e15 :: Float +e15 = f + fromIntegral i1 +e16 :: Integer +e16 = fromIntegral i1 + i2 +e17 :: Int +e17 = i1 + fromInteger i2 -- fromIntegral would have worked too. + +-- Page 17 Section 5.5.4 +module Test(Bool) where + +-- Section 5.5.4 Default Numeric Types + +-- Ambiguous contexts arise frequently in numeric expressions. When an +-- expression which produces a value with a general type, such as +-- `1' (same as `fromInteger 1'; the type is (Num a) => a), with +-- another expression which `consumes' the type, such as `show' or +-- `toInteger', ambiguity arises. This ambiguity can be resolved +-- using expression type signatures, but this gets tedious fast! +-- Assigning a type to the top level of an ambiguous expression does +-- not help: the ambiguity does not propagate to the top level. + +e1 :: String -- This type does not influence the type of the argument to show +e1 = show 1 -- Does this mean to show an Int or a Float or ... +e2 :: String +e2 = show (1 :: Float) +e3 :: String +e3 = show (1 :: Complex Float) + +-- The reason the first example works is that ambiguous numeric types are +-- resolved using defaults. The defaults in effect here are Int and +-- Double. Since Int `fits' in the expression for e1, Int is used. +-- When Int is not valid (due to other context constraints), Double +-- will be tried. + +-- This function defaults the type of the 2's to be Int + +rms :: (Floating a) => a -> a -> a +rms x y = sqrt ((x^2 + y^2) * 0.5) + +-- The C-c e evaluation used to the Haskell system also makes use of +-- defaulting. When you type an expression, the system creates a +-- simple program to print the value of the expression using a function +-- like show. If no type signature for the printed expression is given, +-- defaulting may occur. + +-- One of the reasons for adding type signatures throughout these examples +-- is to avoid unexpected defaulting. Many of the top level signatures are +-- required to avoid ambiguity. + +-- Defaulting can lead to overflow problems when values exceed Int limits. +-- Evaluate a very large integer without a type signature to observe this +-- (unfortunately this may cause a core dump or other unpleasantness). + +-- Notice that defaulting applies only to numeric classes. The +-- show (read "xyz") -- Try this if you want! +-- example uses only class Text so no defaulting occurs. + +-- Ambiguity also arises with polymorphic types. As discussed previously, +-- expressions like [] have a similar problem. + +-- e4 = [] -- Won't work since [] has type [a] and `a' is not known. + +-- Note the difference: even though the lists have no components, the type +-- of component makes a difference in printing. + +e5 = ([] :: [Int]) +e6 = ([] :: [Char]) + +-- Page 18 Sections 6, 6.1, 6.2 + +-- Section 6 Modules + +module Tree ( Tree(Leaf,Branch), fringe ) where +-- Tree(..) would work also + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +fringe :: Tree a -> [a] +fringe (Leaf x) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +-- The Emacs interface to Haskell performs evaluation within the +-- module containing the cursor. To evaluate e1 you must place the +-- cursor in module Main. + +module Main (Tree) where +import Tree ( Tree(Leaf, Branch), fringe) +-- import Tree -- this would be the same thing +e1 :: [Int] +e1 = fringe (Branch (Leaf 1) (Leaf 2)) + +-- This interactive Haskell environment can evaluate expressions in +-- any module. The use of module Main is optional. + +-- Section 6.1 Original Names and Renaming + +module Renamed where +import Tree ( Tree(Leaf,Branch), fringe) + renaming (Leaf to Root, Branch to Twig) + +e2 :: Tree Int +e2 = Twig (Root 1) (Root 2) -- Printing always uses the original names + +-- Section 6.2 Interfaces and Implementations + +-- Yale Haskell allows separate compilation of modules using +-- unit files. These are described in the user's guide. + + +-- Page 19 Sections 6.3, 6.4 + +-- Section 6.3 Abstract Data Types + +-- Since TreeADT does not import Tree it can use the name Tree without +-- any conflict. Each module has its own separate namespace. + +module TreeADT (Tree, leaf, branch, cell, left, + right, isLeaf) where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +leaf = Leaf +branch = Branch +cell (Leaf a) = a +left (Branch l r) = l +right (Branch l r) = r +isLeaf (Leaf _) = True +isLeaf _ = False + +module Test where +import TreeADT + +-- Since the constructors for type Tree are hidden, pattern matching +-- cannot be used. + +fringe :: Tree a -> [a] +fringe x = if isLeaf x then [cell x] + else fringe (left x) ++ fringe (right x) + +e1 :: [Int] +e1 = fringe (branch (branch (leaf 3) (leaf 2)) (leaf 1)) + +-- Section 6.4 + + +-- Page 20 Sections 7, 7.1, 7.2, 7.3 + +-- Section 7 Typing Pitfalls + +-- Section 7.1 Let-Bound Polymorphism + +module Test(e2) where + +-- f g = (g 'a',g []) -- This won't typecheck. + +-- Section 7.2 Overloaded Numerals + +-- Overloaded numerics were covered previously - here is one more example. +-- sum is a prelude function which sums the elements of a list. + +average :: (Fractional a) => [a] -> a +average xs = sum xs / fromIntegral (length xs) + +e1 :: Float -- Note that e1 would default to Double instead of Int - + -- this is due to the Fractional context. +e1 = average [1,2,3] + +-- Section 7.3 The Monomorphism Restriction + +-- The monomorphism restriction is usually encountered when functions +-- are defined without parameters. If you remove the signature for sum' +-- the monomorphism restriction will apply. +-- This will generate an error if either: +-- sum' is added to the module export list at the start of this section +-- both sumInt and sumFloat remain in the program. +-- If sum' is not exported and all uses of sum' have the same overloading, +-- there is no type error. + +sum' :: (Num a) => [a] -> a +sum' = foldl (+) 0 -- foldl reduces a list with a binary function + -- 0 is the initial value. + +sumInt :: Int +sumInt = sum' [1,2,3] + +sumFloat :: Float +sumFloat = sum' [1,2,3] + +-- If you use overloaded constants you also may encounter monomorphism: + +x :: Num a => a +x = 1 -- The type of x is Num a => a +y :: Int +y = x -- Uses x as an Int +z :: Integer +z = x -- Uses x as an Integer. A monomorphism will occur of the + -- signature for x is removed. + -- comments to see an error. + +-- Finally, if a value is exported it must not be overloaded unless bound +-- by a function binding. e2 is the only value exported. + +e2 :: Int -- Remove this to get an error. Without this line e1 will + -- be overloaded. +e2 = 1 + +-- To prevent annoying error messages about exported monomorphic variables, +-- most modules in this tutorial do not implicitly export everything - they +-- only export a single value, Bool, which was chosen to keep the export +-- list non-empty (a syntactic restriction!). In Haskell systems without +-- the evaluator used here, a module which does not export any names would +-- be useless. + +-- module Test where -- this would export everything in the module +-- module Test(Bool) -- exports only Bool +-- module Test() -- this is what we really want to do but is not valid. + +-- Page 21 Sections 8, 8.1 + +module Test(Bool) where + +-- Section 8 Input/Output +-- Section 8.1 Introduction to Continuations + +-- Simplify f here to be 1/x. + +data Maybe a = Ok a | Oops String deriving Text + +f :: Float -> Maybe Float +f x = if x == 0 then Oops "Divide by 0" else Ok (1/x) + +-- g is a `safe' call to x. The call to error could be replaced by +-- some explicit value like Oops msg -> 0. + +g x = case f x of + Ok y -> y + Oops msg -> error msg + +e1 = f 0 +e2 = g 0 +e3 = g 1 + +-- Here is the same example using continuations: + +f' :: Float -> (String -> Float) -> Float +f' x c = if x == 0 then c "Divide by 0" + else 1/x + +g' x = f' x error -- calls error on divide by 0 +g'' x = f' x (\s -> 0) -- returns 0 on divide by 0 + +e4 = g' 0 +e5 = g'' 0 + +-- Page 22 Sections 8.2, 8.3 + +module Test where + +-- Section 8.2 Continuation Based I/O + +-- We will skip the program fragments at the start of this section and +-- move directly to the writeFile / readFile example. + +-- Before we can use Haskell I/O, we need to introduce a new Emacs command: +-- C-c r. This command runs a dialogue instead of printing a value. +-- (Actually C-c e creates a dialogue on the fly and runs it in the same +-- manner as C-c r). As with C-c e you are prompted for an expression. +-- In this case, the expression must be of type Dialogue and it is +-- executed by the I/O system. We use d1,d2,... for dialogues to be +-- executed by C-c r. + +-- We make the file name a parameter to allow for easier testing. +-- Don't expect much error handling in exit. + +s1 = "This is a test of Haskell" + +main file = writeFile file s1 exit ( + readFile file exit (\s2 -> + appendChan stdout (if s1==s2 then "contents match" + else "something intervened!") exit + done)) + +d1,d2 :: Dialogue +d1 = main "/tmp/ReadMe" +d2 = main "/dev/null" -- this will read back as the empty string + +-- A simple IO program using $ for readability: ($ is defined in the Prelude) + +d3 = appendChan "stdout" "Type something: " exit $ + readChan "stdin" exit $ \s2 -> + appendChan "stdout" ("You typed " ++ head (lines s2)) exit $ + done + +-- This program suffers from a strictness problem. Strictness deals +-- with when things get evaluated. In this program, the input is not +-- needed until after the "You typed " is printed. Fixing this would +-- require some operation to look at the string before the final +-- appendChan. Here is one possible fix: + +d4 = appendChan "stdout" "Type something: " exit $ + readChan "stdin" exit $ \s2 -> + let str = head (lines s2) in + if str == str then -- This evaluates str + appendChan "stdout" ("You typed " ++ head (lines s2)) exit $ + done + else done + + +-- Section 8.3 Terminal I/O + +-- Since this programming environment runs under Emacs, the issue of +-- echoing does not really apply. However, the synchronization between +-- input and output can be seen in the following example. Since the input +-- comes a line at a time, the X's come in groups between input lines. +-- The cursor will move into the haskell dialogue buffer when the program +-- requests input. Use a ^D to stop the program (^Q^D actually). [Warning: +-- some brain damaged lisps stop not only the Haskell program but also +-- the entire compiler on ^D] + +d5 = readChan stdin exit processInput where + processInput s = loop 1 s + loop n [] = done + loop n (x:xs) | n == 10 = appendChan stdout "X" exit (loop 1 xs) + | True = loop (n+1) xs + +-- For more examples using the I/O system look in the demo programs +-- that come with haskell (in $HASKELL/progs/demo) and the report. + +-- Page 23 Sections 9, 9.1, 9.2 + +module Test(Bool) where + +-- Section 9 Arrays +-- Section 9.1 Index Types + +-- Arrays are built on the class Ix. Here are some quick examples of Ix: + +e1 :: [Int] +e1 = range (0,4) +e2 :: Int +e2 = index (0,4) 2 +low,high :: (Int,Int) +low = (1,1) +high = (3,4) +e3 = range (low,high) +e4 = index (low,high) (3,2) +e5 = inRange (low,high) (4,3) + +-- Section 9.2 Array Creation + +squares :: Array Int Int +squares = array (1,100) [i := i*i | i <- [1..100]] + +-- We can also parameterize this a little: + +squares' :: Int -> Array Int Int +squares' n = array (1,n) [i := i*i | i <- [1..n]] + +e6 :: Int +e6 = squares!6 +e7 :: (Int,Int) +e7 = bounds squares +e8 :: Array Int Int +e8 = squares' 10 + +-- Here is a function which corresponds to `take' for lists. It takes +-- an arbitrary slice out of an array. + +atake :: (Ix a) => Array a b -> (a,a) -> Array a b +atake a (l,u) | inRange (bounds a) l && inRange (bounds a) u = + array (l,u) [i := a!i | i <- range (l,u)] + | otherwise = error "Subarray out of range" + +e9 = atake squares (4,8) + +mkArray :: Ix a => (a -> b) -> (a,a) -> Array a b +mkArray f bnds = array bnds [i := f i | i <- range bnds] + +e10 :: Array Int Int +e10 = mkArray (\i -> i*i) (1,10) + +fibs :: Int -> Array Int Int +fibs n = a where + a = array (0,n) ([0 := 1, 1 := 1] ++ + [i := a!(i-1) + a!(i-2) | i <- [2..n]]) + +e11 = atake (fibs 50) (3,10) + +wavefront :: Int -> Array (Int,Int) Int +wavefront n = a where + a = array ((1,1),(n,n)) + ([(1,j) := 1 | j <- [1..n]] ++ + [(i,1) := 1 | i <- [2..n]] ++ + [(i,j) := a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j) + | i <- [2..n], j <- [2..n]]) + +wave = wavefront 20 +e12 = atake wave ((1,1),(3,3)) +e13 = atake wave ((3,3),(5,5)) + +-- Here are some errors in array operations: + +e14 :: Int +e14 = wave ! (0,0) -- Out of bounds +arr1 :: Array Int Int +arr1 = array (1,10) [1 := 1] -- No value provided for 2..10 +e15,e16 :: Int +e15 = arr1 ! 1 -- works OK +e16 = arr1 ! 2 -- undefined by array + +-- Page 24 Sections 9.3, 9.4 + +module Test(Bool) where + +-- Section 9.3 Accumulation + +hist :: (Ix a, Integral b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [i := 1 | i <- is, inRange bnds i] + +e1 :: Array Char Int +e1 = hist ('a','z') "This counts the frequencies of each lowercase letter" + +decades :: (RealFrac a) => a -> a -> [a] -> Array Int Int +decades a b = hist (0,9) . map decade + where + decade x = floor ((x-a) * s) + s = 10 / (b - a) + +test1 :: [Float] +test1 = map sin [0..100] -- take the sine of the 0 - 100 +e2 = decades 0 1 test1 + +-- Section 9.4 Incremental Updates + +swapRows :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c +swapRows i i' a = a // ([(i,j) := a!(i',j) | j <- [jLo..jHi]] ++ + [(i',j) := a!(i,j) | j <- [jLo..jHi]]) + where ((iLo,jLo),(iHi,jHi)) = bounds a + +arr1 :: Array (Int,Int) (Int,Int) +arr1 = array ((1,1),(5,5)) [(i,j) := (i,j) | (i,j) <- range ((1,1),(5,5))] + +e3 = swapRows 2 3 arr1 + +-- Printing the arrays in more readable form makes the results easier +-- to view. + +-- This is a printer for 2d arrays + +aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where + showRows r c | r > ux = showChar '\n' + showRows r c | c > uy = showChar '\n' . showRows (r+1) ly + showRows r c = showElt (a!(r,c)) . showRows r (c+1) + showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' ' + ((lx,ly),(ux,uy)) = bounds a + +showArray a w = appendChan stdout (aprint a w "") abort done + +d1 = showArray e3 6 + +swapRows' :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c +swapRows' i i' a = a // [assoc | j <- [jLo..jHi], + assoc <- [(i,j) := a!(i',j), + (i',j) := a!(i,j)]] + where ((iLo,jLo),(iHi,jHi)) = bounds a + +d2 = showArray (swapRows' 1 5 arr1) 6 + +-- Page 25 Section 9.5 + +module Test(Bool) where + +-- Section 9.5 An example: Matrix Multiplication + +aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where + showRows r c | r > ux = showChar '\n' + showRows r c | c > uy = showChar '\n' . showRows (r+1) ly + showRows r c = showElt (a!(r,c)) . showRows r (c+1) + showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' ' + ((lx,ly),(ux,uy)) = bounds a + +showArray a w = appendChan stdout (aprint a w "") abort done + +matMult :: (Ix a, Ix b, Ix c, Num d) => + Array (a,b) d -> Array (b,c) d -> Array (a,c) d +matMult x y = + array resultBounds + [(i,j) := sum [x!(i,k) * y!(k,j) | k <- range (lj,uj)] + | i <- range (li,ui), + j <- range (lj',uj')] + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +mat1,mat2,mat3,mat4 :: Array (Int,Int) Int +mat1 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 0,(1,0) := 0,(1,1) := 1] +mat2 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 1,(1,0) := 1,(1,1) := 1] +mat3 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 2,(1,0) := 3,(1,1) := 4] +mat4 = array ((0,0),(1,2)) [(0,0) := 1,(0,1) := 2,(0,2) := 3, + (1,0) := 4,(1,1) := 5,(1,2) := 6] + +d1 = showArray (matMult mat1 mat2) 4 +d2 = showArray (matMult mat2 mat3) 4 +d3 = showArray (matMult mat1 mat4) 4 +d4 = showArray (matMult mat4 mat1) 4 + +matMult' :: (Ix a, Ix b, Ix c, Num d) => + Array (a,b) d -> Array (b,c) d -> Array (a,c) d +matMult' x y = + accumArray (+) 0 ((li,lj'),(ui,uj')) + [(i,j) := x!(i,k) * y!(k,j) + | i <- range (li,ui), + j <- range (lj',uj'), + k <- range (lj,uj)] + + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +d5 = showArray (matMult mat1 mat2) 4 +d6 = showArray (matMult mat2 mat3) 4 + +genMatMul :: (Ix a, Ix b, Ix c) => + ([f] -> g) -> (d -> e -> f) -> + Array (a,b) d -> Array (b,c) e -> Array (a,c) g +genMatMul f g x y = + array ((li,lj'),(ui,uj')) + [(i,j) := f [(x!(i,k)) `g` (y!(k,j)) | k <- range (lj,uj)] + | i <- range (li,ui), + j <- range (lj',uj')] + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +d7 = showArray (genMatMul maximum (-) mat2 mat1) 4 +d8 = showArray (genMatMul and (==) mat1 mat2) 6 +d9 = showArray (genMatMul and (==) mat1 mat1) 6 + +-- Page 26 More about Haskell + +This is the end of the tutorial. If you wish to see more examples of +Haskell programming, Yale Haskell comes with a set of demo programs. +These can be found in $HASKELL/progs/demo. Once you have mastered the +tutorial, both the report and the user manual for Yale Haskell should +be understandable. Many examples of Haskell programming can be found in +the Prelude. The directory $HASKELL/progs/prelude contains the sources +for the Prelude. + +We appreciate any comments you have on this tutorial. Send any comments +to haskell-requests@cs.yale.edu. + + The Yale Haskell Group |