@@ -0,0 +1,114 @@
1+
2+module Collage where
3+
4+data Line
5+ = Start (Float,Float)
6+ | Arc (Float,Float) Float (Float,Float) Path
7+ | Line (Float,Float) Path
8+ | Bezier (Float,Float) (Float,Float) (Float,Float) Path
9+ | Quadratic (Float,Float) (Float,Float) Path
10+
11+path ps = case ps of
12+ [] -> Start (0,0)
13+ hd:tl -> foldl Line (Start hd) tl
14+
15+segment p1 p2 = Line p1 (Start p2)
16+
17+start = Start
18+arcTo = Arc
19+lineTo = Line
20+bezierTo = Bezier
21+quadraticTo = Quadratic
22+
23+data Shape = Shape Line
24+
25+polygon ps = Shape (case ps of
26+ [] -> Start (0,0)
27+ hd:tl -> Line hd $ foldl Line (Start hd) tl)
28+
29+rect w h = polygon [ (0-w/2,0-h/2), (0-w/2,h/2), (w/2,h/2), (w/2,0-h/2) ]
30+oval w h =
31+ let n = 50
32+ f i = ( w/2 * cos (2*pi/n * i), h/2 * sin (2*pi/n * i))
33+ in Shape $ map f [0..n-1]
34+circle r = oval (2*r) (2*r)
35+ngon n r =
36+ let m = toFloat n
37+ f i = ( r * cos (2*pi/m * i), r * sin (2*pi/m * i))
38+ in Shape $ map f [0..n-1]
39+
40+data Transform
41+ = Rotate Float
42+ | Move Float Float
43+ | Scale Float Float
44+ | Transform Float Float Float Float Float Float
45+
46+data Form = Form [Transform] BasicForm
47+
48+
49+data LineCap = Butt | Round | Square
50+data LineJoin = Round | Bevel | Miter
51+
52+data FillStyle
53+ = NoFill
54+ | Solid Color
55+ | Texture String
56+ | LinearGradient [(Float,Color)] (Float,Float) (Float,Float)
57+ | RadialGradient [(Float,Color)] (Float,Float) Float (Float,Float) Float
58+
59+data LineStyle = NoLine | Line [Int] Int Float LineCap LineJoin Float FillStyle
60+
61+data BasicForm
62+ = FLine LineStyle FillStyle Line
63+ | FShape LineStyle FillStyle Shape
64+ | FImage Int Int String
65+ | FElement Element
66+ | FGroup [Form]
67+
68+setFillStyle fs form =
69+ case form of
70+ FLine ls _ ln -> FLine ls fs ln
71+ FShape ls _ shp -> FLine ls fs shp
72+ _ -> form
73+
74+noFill = setFillStyle NoFill
75+fillColor clr = setFillStyle (Solid clr)
76+texture src = setFillStyle (Texture src)
77+linearGradient stops start end = setFillStyle (LinearGradient stops start end)
78+radialGradient stops innerP innerR outerP outerR =
79+ setFillStyle (RadialGradient stops innerP innerR outerP outerR)
80+
81+solid clr ln = Form [] (FLine ln)
82+dotted clr ln = Form [] (FLine ln)
83+dashed clr ln = Form [] (FLine ln)
84+customLine pattern clr ln = Form [] (FLine (Custom pattern) clr ln)
85+
86+
87+filled clr shp = Form [] (FShape shp)
88+outlined clr shp = Form [] (FShape shp)
89+customOutline pattern clr (Shape ps pos) =
90+ Form [] (FShape (CustomOutline pattern) clr (Shape ps pos))
91+textured src (Shape ps pos) = Form [] (FShape (Textured src) black (Shape ps pos))
92+
93+fromLine = FLine
94+fromShape = FShape
95+fromElement = FElement
96+
97+sprite w h pos src = Form 0 1 pos (FImage w h src)
98+toForm pos e = Form 0 1 pos (FElement e)
99+
100+addTransform t (Form ts form) = Form (t:ts) form
101+
102+rotateRad rad = addTransform $ Rotate rad
103+rotateDeg deg = addTransform $ Rotate (pi * deg / 180)
104+rotate rot = addTransform $ Rotate (2 * pi * rot)
105+
106+scale s = addTransform (Scale s s)
107+scaleX s = addTransform (Scale s 1)
108+scaleY s = addTransform (Scale 1 s)
109+
110+move x y = addTransform (Move x y)
111+moveX x = addTransform (Move x 0)
112+moveY y = addTransform (Move 0 y)
113+
114+transform a b c d e f = addTransform (Transform a b c d e f)