module PostScript where

data Point = Car Cartes | Pol Polar
type Cartes = (Coord, Coord)
type Coord = Double
type Polar = (Radius, Angle)
type Radius = Double
type Angle = Double
type Line = (Point, Point)


cartesToPolar :: Cartes -> Polar
cartesToPolar (x,y) = (sqrt (x*x + y*y), atan2 y x)

polarToCartes :: Polar -> Cartes
polarToCartes (r,a) = (r*cos a, r*sin a)

pointToPolar :: Point -> Polar
pointToPolar (Car cp) = cartesToPolar cp
pointToPolar (Pol pp) = pp

pointToCartes :: Point -> Cartes
pointToCartes (Car cp) = cp
pointToCartes (Pol pp) = polarToCartes pp

lineLength :: Line -> Double
cartesLength ((x,y),(z,u)) = sqrt( (x-z)*(x-z) + (y-u)*(y-u) )
lineLength (p,q) = cartesLength(pointToCartes p, pointToCartes q)
addPt :: Point -> Point -> Point
addPt p1 p2 = Car (addCPt (pointToCartes p1) (pointToCartes p2))

addCPt :: Cartes -> Cartes -> Cartes
addCPt (x1,y1) (x2,y2) = (x1+x2, y1+y2)

midCPt  :: Cartes -> Cartes -> Cartes
midCPt  (x1,y1) (x2,y2) = ((x1+x2)/2.0, (y1+y2)/2.0)

midPt :: Point -> Point -> Point
midPt p1 p2 = Car (midCPt (pointToCartes p1) (pointToCartes p2))

subCPt :: Cartes -> Cartes -> Cartes
subCPt (x1,y1) (x2,y2) = (x1-x2, y1-y2)

subPt :: Point -> Point -> Point
subPt p1 p2 = Car (subCPt (pointToCartes p1) (pointToCartes p2))

multCPt d (x,y) = (d * x, d * y)
multPPt d (r,a) = (d * r, a)

multPt :: Double -> Point -> Point
multPt d (Car c) = Car (multCPt d c)
multPt d (Pol p) = Pol (multPPt d p)

on_line :: Double -> Point -> Point -> Point
on_line f p1 p2 =
  let cp1 =  pointToCartes p1
      d = subCPt (pointToCartes p2) cp1
  in Car (addCPt cp1 (multCPt f d))

transCPt w h (x,y) = (w * x, h * y)

ps_of_int :: Int -> String
ps_of_int x = (if x < 0 then '-' : show (-x) else show x) ++ " "

ps_of_double :: Double -> String
ps_of_double x = (if x < 0 then '-' : show (-x) else show x) ++ " "

ps_of_cartes :: Cartes -> String
ps_of_cartes (x,y) = ps_of_double x ++ ps_of_double y

ps_of_point :: Point -> String
ps_of_point = ps_of_cartes . pointToCartes

ps_of_points = concat . map ps_of_point

setrgbcolor :: (Double, Double, Double) -> String
setrgbcolor (r,g,b) = ps_of_double r ++ ps_of_double g ++ ps_of_double b
                      ++ "setrgbcolor"


ps_of_line :: Line -> String
ps_of_line (p1,p2) =
  "newpath\n" ++ ps_of_point p1 ++ " moveto\n"
              ++ ps_of_point p2 ++ " lineto\nstroke"

ps_set_linewidth :: Double -> String
ps_set_linewidth w = ps_of_double w  ++ " setlinewidth"

pspath, polygon_pspath :: [Point] -> String
pspath [] = error "empty path"
pspath [_] = error "singleton path"
pspath (p:ps) =
  ps_of_point p ++ " moveto\n" ++
  unwords (map (\ p -> ps_of_point p ++ " lineto\n") ps)

polygon_pspath ps = "newpath\n" ++ polygon_pspath0 ps

polygon_pspath0 ps = pspath ps ++ " closepath"

arcprolog = "/hpsarcdict 6 dict def\nhpsarcdict /mtrx matrix put"

arc :: Point -> Cartes -> Double -> Double -> String
arc ctr rads startangle endangle =
  "hpsarcdict begin\n"
  ++ "/savematrix mtrx currentmatrix def\n"
  ++ ps_of_point ctr ++ "translate\n"
  ++ ps_of_cartes rads ++ "scale\n"
  ++ "0 0 1 " ++ ps_of_double startangle ++ ps_of_double endangle ++ "arc\n"
  ++ "savematrix setmatrix end"

type PostScript = [String]
type PostScriptS = [String] -> [String] -- as ShowS

type Style = PostScriptS -> PostScriptS

wrap begin end pss = (begin :) . pss . (end :)
save = wrap "save" "restore"
gsave = wrap "gsave" "grestore"

caps :: Style
caps = save . gsave

scale :: (Double,Double) -> Style
scale (sx,sy) = caps .
  (((ps_of_double sx ++ ps_of_double sy ++ "scale") :) .)

translate :: (Double,Double) -> Style
translate (sx,sy) = caps .
  (((ps_of_double sx ++ ps_of_double sy ++ "translate") :) .)

rotate :: Double -> Style
rotate angle = caps . (((ps_of_double angle ++ "rotate") :) .)

setfont :: String -> Double -> Style
setfont font size = caps .
  ((("/" ++  font ++ " findfont " ++ ps_of_double size ++
     "scalefont setfont") :) .)

ps_of_bb1 (ll,ur) = let
  (left,lower) = pointToCartes ll
  (right,upper) = pointToCartes ur
  b = (' ' :)
 in (show (floor   left - 1)) ++ b (show (floor lower - 1)) ++
  b (show (ceiling right + 1)) ++ b (show (ceiling upper + 1))

ps_of_bb (ll,ur) = let
  (left,lower) = pointToCartes ll
  (right,upper) = pointToCartes ur
  b = (' ' :)
 in (show (floor   left )) ++ b (show (floor lower  )) ++
  b (show (ceiling right)) ++ b (show (ceiling upper))

ps_of_bb' (ll,ur) =
 ps_of_point ll ++ ' ' : ps_of_point ur

prolog :: String -> (Point,Point) -> PostScript
prolog title bb =
  ["%!PS-Adobe-2.0 EPSF-2.0\n%%Title: " ++ title
  ,"%%BoundingBox: " ++ ps_of_bb bb
  ,"%%Pages: 1"
  ,"%%DocumentFonts:"
  ,"%%EndComments"
  ,"%%EndProlog\n"
  ,"%%Page: 1 1"
  ]