>|| graphics.m
>%include "myenv"

A picture is just a list of objects.

> picture == [object]

The basic elements that make up a picture.

> object ::= Line path | Text string [justification] point | Arc num num point num | Attrib [attrib] picture
> justification ::= Left | Right | Above | Below
> attrib ::= Grey num | Linewidth num | Dashpattern dashpattern | Clipregion rectangle | Colour num num num
> dashpattern ::= None | Continuous | Dashed | Dotted | Dashdotted

> rectangle == (point,point)
> path == [point]
> shade == num

points are just ordered pairs of numbers.

 point == (num,num)

Create a filled polygon

> fill_polygon :: num -> path -> object
> fill_polygon g ps = Attrib [Dashpattern None,Grey g] [Line ps]

A circle:

> circle :: point -> num -> object
> circle = Arc 0 (2*pi)

An arbitrary curve segment can be represented by a parametric
equation, and an interval in parameter space.

> curve_segment == (num -> point,[num])

Draw a curve segment, clipped to a cliprectangle.

> curve_clip :: num -> rectangle -> curve_segment -> object
> curve_clip eps rect (f,ts)
>    = Line (concat [(curve_clip' eps rect (f,[b,e]))|(b,e)<-zip2 ts (tl ts)])
> curve_clip' :: num -> rectangle -> curve_segment -> [point]
> curve_clip' eps rect (f,[b,e])
>    = [], if intersection cfb cfe ~= []
>    = curve eps (f,[b,e]), if d2 fb fe < eps \/ cfb = cfe = []
>    = secondhalf, if firsthalf = []
>    = firsthalf ++ (drop 1 secondhalf), otherwise
>      where
>      mid = (b+e)/2
>      fe = f e
>      fb = f b
>      cfe = classify rect fe
>      cfb = classify rect fb
>      firsthalf = curve_clip' eps rect (f,[b,mid])
>      secondhalf = curve_clip' eps rect (f,[mid,e])

Draw a curve segment.  We use recursive subdivision until things are
flat enough.

> curve :: num -> curve_segment -> [point]
> curve eps (f,[b,e]) =
>    f b:curve' eps (f b) (f e) (f,[b,e])

> curve' :: num -> point -> point -> curve_segment -> [point]
> curve' eps fb fe (f,[b,e])
>    = [fe], if len < eps \/ d < eps
>    = curve' eps fb fmid (f,[b,mid]) ++ curve' eps fmid fe (f,[mid,e]), otherwise
>      where mid = (b+e)/2
>            fmid = f mid
>            len = d2 fb fe
>            d = abs(area [fb,fmid,fe])/len

Classify a point wrt a cliprectangle

> classify :: rectangle -> point -> [justification]
> classify ((l,b),(r,t)) (x,y)
>    = lr++ab
>      where lr = [Left], if x<l
>               = [Right], if x>r
>               = [], otherwise
>            ab = [Above], if y>t
>               = [Below], if y<b
>               = [], otherwise

Shift a picture. e.g shift (1,2) moves the whole picture 1 unit left and up 2.
We do this by shifting every single point that makes it up.

> shift :: point -> picture -> picture
> shift t = mappic (shiftpoint t)

Rotate a picture. e.g rotate 10 rotates the picture by 10 degrees about (0,0)

> rotate :: num -> picture -> picture
> rotate t = mappic (rotatepoint t)

Scale a picture. e.g. scale (2,2) makes the whole picture twice as big.

> scale :: point -> picture -> picture
> scale t = mappic (scalepoint t)

The next three functions shift, scale and rotate points.
 
> shiftpoint:: point->point->point
> shiftpoint (tx,ty) (x,y) = (tx+x,ty+y)
 
> scalepoint:: point->point->point
> scalepoint (sx,sy) (x,y) = (sx*x,sy*y)
 
> rotatepoint:: num->point->point
> rotatepoint angle (x,y) = (x*cos theta - y*sin theta , x*sin theta + y*cos theta)
>                           where theta = angle * pi / 180

Takes a function of type point->point and applies it to every point in a picture
It is similar to map.

>mappic:: (point -> point) -> picture -> picture
> mappic f pic 
>  = map fpic pic
>    where fpic (Line xs) = Line (map f xs)
>          fpic (Text s j x) = Text s j (f x)
>	   fpic (Arc b e p r) = Arc (b+t) (e+t) (f p) r'
>				where (x,y) = f (r,0)
>				      (x',y') = f (0,0)
>				      (r',t) = polar(x-x',y-y')
>	   fpic (Attrib as pic) = Attrib (map fa as) (mappic f pic)
>	   fa (Clipregion (bl,tr)) = Clipregion ((f bl),(f tr))
>	   fa a = a

filterpic take a function of type object->bool and returns a picture
containing only the objects for which this predicate is true.

> filterpic:: (object->bool) -> picture -> picture
> filterpic p
>    = filter p . map fp
>      where fp (Attrib as pic) = Attrib as (filterpic p pic)
>            fp x = x

isArc is true if the object is an Arc

> isArc :: object -> bool
> isArc (Arc b e p r) = True
> isArc x = False

> arch = getenv "ARCH"

animate displays a sequence of pictures.

> animate :: [picture] -> [sys_message]
> animate ps
>    = draw_init ++ concat(map draw_nop ps),if arch="apollo.m68k.domainos"
>    = [Tofile pspipefilename (pslist ps),
>       System("dxpsview "++pspipefilename++"&")],if arch="dec.mips.ultrix"
>    = [Tofile pspipefilename (pslist ps),
>       System("/usr/local/bin/ghostview "++pspipefilename++"&")],if arch="sun.sparc.solaris"
>    = error ("Don't know how to draw on architecture"++arch), otherwise


draw actually draws the picture in a separate window.  It works by magic
(well not really - it produces a file that is read by another program).
 
> draw:: picture->[sys_message]
> draw p = animate [p]

> pspipefilename = "/tmp/Miranda_Graphics.ps"
> pipename = "/tmp/mira_view_pipe"
> mybin = "/home/lambert/bin." ++ arch ++ "/"
> draw_nop p = [Tofile pipename (draw' p)]

> draw_init
>    = [], if filemode pipename = "-rw-"
>    =  [System ("/etc/sys5.3/mknod "++pipename++" p"),
>        System ("("++mybin++"/mira_view<"++pipename++
>                 ";rm "++pipename++")&")],otherwise

drawone draws a single object
 
> drawone:: object->[char]
> drawone (Line apath) = "L\n"++ listpath apath ++"\n"
> drawone (Text astring just apoint) = "T"++map (hd.show) just++"\n"++listpoint apoint ++astring++"\n"
> drawone (Arc begin end apoint radius) = "I"++" "++showscaled 5 radius++"\n"++listpoint apoint
> drawone (Attrib as pic) = "A\n"++lay (map showattr as)++"\n"++draw' pic

draw' converts picture to a string representation

> draw':: picture->[char]
> draw' p = concat (map drawone p) ++ "E\n"

prints the coordinates of all the points in the path
 
> listpath:: path->[char]
> listpath = concat.map listpoint
 
prints the coordinates of a single point

> listpoint:: point->[char]
> listpoint (x,y) = showscaled 5 x ++ " " ++ showscaled 5 y ++ "\n"

showattr outputs each attribute

> showattr :: attrib -> [char]
> showattr (Grey g) = "G" ++ showscaled 5 g
> showattr (Colour r g b) = "C" ++ showscaled 5 r ++ " " ++ showscaled 5 g ++ " " ++ showscaled 5 b ++ " "
> showattr (Linewidth w) = "W" ++ showscaled 5 w
> showattr (Dashpattern None) = "D -1"
> showattr (Dashpattern Continuous) = "D 0"
> showattr (Dashpattern Dotted) = "D 1"
> showattr (Dashpattern Dashed) = "D 2"
> showattr (Dashpattern Dashdotted) = "D 3"
> showattr (Clipregion (bl,tr)) = "R\n" ++ listpoint bl ++ init(listpoint tr)


Find extreme x and y co-ordinates in a picture

> extremes:: picture -> (num,num,num,num)
> extremes pic = (minx,miny,maxx,maxy)
>                where minx = min xs
>                      miny = min ys
>                      maxx = max xs
>                      maxy = max ys
>                      (xs,ys) = unzip (points pic)

returns a list containing all the points in a picture

> points:: picture -> path
> points = concat.map pointobj

all the points in an object

> pointobj:: object -> path
> pointobj (Line ps) = ps
> pointobj (Text s j p) = [p]
> pointobj (Arc b e (x,y) r) = [(x+r*cos t,y+r*sin t) | t <- angles]
>			       where angles = b:e:[t|t<-map torad[-90,0,90,180,270,360];b<t<e]
> pointobj (Attrib as pic) = points pic, if apoints = []
>                          = apoints, otherwise
>			     where apoints = concat[[bl,tr]|(Clipregion (bl,tr)) <-as]


Name of file contain PostScript prologue (definitions of PostScript
functions used).

> prologue = tryread ["/home/lambert/miranda/graphics.ps"]

Given a matrix of pictures, generate postscript to fit them all
onto an A4 page.

> psmatrix :: [[picture]] -> [char]
> psmatrix picss
>  = header 1 (a4xmin,a4ymin,a4xmax,a4ymax) ++
>    "%%Page: 1 1\nbeginpage\n" ++
>    psmatrix' picss ++
>    "endpage\n" ++
>    trailer

> psmatrix' :: [[picture]] -> [char]
> psmatrix' picss
>  = listpoint (scal,scal) ++ "scale\n" ++
>    "setsc\n" ++
>    "/charheight charheight "++show scal++" div def\n" ++
>    "currentfont 1 "++show scal++" div scalefont setfont\n" ++
>    concat(map (psrow colposs) (zip2 (reverse picss) rowposs))
>    where cols = max (map (#) picss) || # of columns
>          rows = #picss            || # of rows
>	   scal = min [(a4xmax-a4xmin-cols*margin)/cols,
>	               (a4ymax-a4ymin-rows*margin)/rows]/res
>          xgap = (a4xmax-a4xmin)/(scal*cols)    || spacing between start of each pic in x dirn
>	   ygap = (a4ymax-a4ymin)/(scal*rows)    || spacing between start of each pic in y dirn
>	   xoffset = a4xmin/scal + (xgap-res)/2    || offset of first pic in x
>	   yoffset = a4ymin/scal + (ygap-res)/2    || offset of first pic in y
>	   colposs = map (xoffset+) (map (xgap*) [0..cols-1])   || x position of each column
>	   rowposs = map (yoffset+) (map (ygap*) [0..rows-1])   || y position of each row



generate one row of pictures

> psrow :: [num] -> ([picture],num) -> [char]
> psrow xs (pics,y) = concat(map (psone y) (zip2 pics xs))

generate postscript to draw a picture at (x,y)

> psone :: num -> (picture,num) -> [char]
> psone y (pic,x) = "gsave\n" ++ 
>                   listpoint (x,y) ++ "translate\n" ++
>                   postscript pic ++
>                   "grestore\n"

These are the dimensions of an A4 page on the Laserwriter.

> a4xmin = 20
> a4xmax = 570
> a4ymin = 50  || leave a slightly larger margin at bottom
> a4ymax = 810
> margin = 10  || # of points of space to leave around each picture

Take a list of pictures and print them one per page.

> pslist :: [picture] -> [char]
> pslist pics
>  = header (#pics) (a4xmin,a4ymin,a4xmax,a4ymax) ++
>    concat ["%%Page: "++show i++" "++show i++"\nbeginpage\n"++psmatrix' [[pic]]++"endpage\n"
>            | (pic,i) <- zip2 pics [1..]] ++
>    trailer


Generate epsf for one picture.

> epsf pic = header 0 (extremes pic)++
>            concat(map psobj pic)++
>            trailer

Header that obeys Adobe comment conventions
We pass it the number of pages and a bounding box.

> header :: num -> (num,num,num,num) -> [char]
> header pages (minx,miny,maxx,maxy)
>    = lay
>      ["%!PS-Adobe-1.0",
>       "%%DocumentFonts: Helvetica",
>       "%%Title: ",
>       "%%Creator: Tim's Miranda Graphics system",
>       "%%CreationDate: "++init date,
>       "%%Pages: "++shownum pages,
>       "%%BoundingBox: "++sho minx++" "++sho miny++" "
>                     ++sho maxx++" "++sho maxy,
>       "%%EndComments"]
>      ++ prologue ++ "%%EndProlog\n"
>      where (date,err,retcode) = system "date"
>            sho = showfloat 1

> trailer = "%%Trailer\n"

Resolution of postscript output

> res = 1000

Generate postscript to draw a picture inside [0,res]x[0,res]

> postscript :: picture->[char]
> postscript = concat.map psobj.unit

Convert a single object to postscript

> psobj :: object -> [char]
> psobj (Line []) = ""
> psobj (Line ps) = pslinepath ps ++ "s\n"
> psobj (Text s j p) = listpoint p ++ vertical j ++" (" ++ escape s ++ ") "++horizontal j++"\n"
> psobj (Arc b e c r) = listpoint c ++ show r ++ " " ++ showfloat 1 (todeg b) ++ " " ++ showfloat 1 (todeg e) ++ " c\n"
> psobj (Attrib as pic) = "save\n"++(concat(map psattr as))++(concat(map psobj pic))++
>			  "restore\n"

Convert attributes to postscript

> psattr :: attrib -> [char]
> psattr (Grey g) = show g ++ " mysetgray\n"
> psattr (Colour r g b) = show r ++ " " ++ show g ++ " " ++ show b ++ " mysetrgbcolour\n"
> psattr (Linewidth w) = show w ++ " w\n"
> psattr (Dashpattern None) = "[0 1] 0 d\n"
> psattr (Dashpattern Continuous) = "[] 0 d\n"
> psattr (Dashpattern Dotted) = "[1 3] 0 d\n"
> psattr (Dashpattern Dashed) = "[4 2] 0 d\n"
> psattr (Dashpattern Dashdotted) = "[3 2 1 2] 0 d\n"
> psattr (Clipregion (bl,tr)) = listpoint bl ++ listpoint tr ++ "clipbox\n"

pslinepath does a lineto for each point in p

> pslinepath :: path -> string
> pslinepath [] = []
> pslinepath ((x,y):ps) =
>     shownumb x ++ " " ++ shownumb y ++ " m\n"++
>     concat [shownumb x ++ " " ++ shownumb y ++ " l\n"|(x,y)<-ps]
> shownumb = shownum

escape parentheses and newlines in postscript strings

> escape :: string -> string
> escape [] = []
> escape ('(':s) = '\\':'(':escape s
> escape (')':s) = '\\':')':escape s
> escape ('\n':s) = '\\':'n':escape s
> escape ('\\':s) = '\\':'\\':escape s
> escape (c:s) = c:escape s

vertical justification postscript command

> vertical :: [justification] -> string
> vertical j = "vc", if member j Above = member j Below
>            = "vt", if member j Below
>            = "vb", if member j Above

horizontal justification postscript command

> horizontal :: [justification] -> string
> horizontal j = "hc", if member j Left = member j Right
>              = "hl", if member j Right
>              = "hr", if member j Left


Scales and shifts picture so that all points lie inside [0,res]x[0,res]
and are integers.

> unit :: picture -> picture
> unit pic = (mappic round.scale (s,s).shift (-minx,-miny)) pic
>            where (minx,miny,maxx,maxy) = extremes pic
>                  s = res/max[maxx-minx,maxy-miny]

Round a point to nearest integer

> round :: point -> point
> round (x,y) = (entier (x+0.5),entier (y+0.5))

tryread is given a list of filenames and returns the contents of the
first one that is readable.

> tryread :: [[char]] -> [char]
> tryread [x] = read x
> tryread (x:xs)
>    = read x, if member (filemode x) 'r'
>    = tryread xs, otherwise