Skip to content

Commit 126c465

Browse files
matheus23matheus23
committed
Port of Cairo.Shape to Canvas.Shape
1 parent 2783253 commit 126c465

File tree

5 files changed

+253
-15
lines changed

5 files changed

+253
-15
lines changed

‎DeclarativeGraphics-JS.cabal

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -16,20 +16,25 @@ cabal-version: >=1.10
1616
library
1717
hs-source-dirs: src
1818
exposed-modules: Graphics.Rendering.Canvas
19-
build-depends: base >= 4.7 && < 5
19+
, Graphics.Declarative.Canvas.Shape
20+
build-depends: base
2021
, mtl
22+
, linear
2123
, ghcjs-dom
2224
, DeclarativeGraphics
2325
default-language: Haskell2010
2426

2527
executable main
26-
main-is: Main.hs
27-
build-depends: base >=4.2 && <5
28+
main-is: Main.hs
29+
build-depends: base
2830
, mtl
31+
, linear
2932
, ghcjs-dom
33+
, DeclarativeGraphics
3034
, DeclarativeGraphics-JS
31-
hs-source-dirs: app
32-
ghc-options: -threaded
35+
hs-source-dirs: app
36+
ghc-options: -threaded
37+
default-language: Haskell2010
3338

3439
source-repository head
3540
type: git

‎app/Main.hs

Lines changed: 13 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,9 @@ import GHCJS.DOM.Node
99

1010
import Graphics.Rendering.Canvas
1111

12+
import Graphics.Declarative.Canvas.Shape as Shape
13+
import Graphics.Declarative.Bordered
14+
1215
main :: IO ()
1316
main = liftJSM helloMain
1417

@@ -26,16 +29,19 @@ helloMain = do
2629
render :: Canvas ()
2730
render = do
2831
fillStyle "rgb(200, 0, 0)"
29-
fillRect 10 10 90 50
32+
beginPath
33+
rect 10 10 90 50
34+
fill
3035

3136
fillStyle "rgba(0, 0, 200, 0.5)"
32-
fillRect 30 30 50 50
37+
beginPath
38+
rect 30 30 50 50
39+
fill
3340

3441
fillText 10 90 "Hello, GHCJS!"
3542

36-
beginPath
37-
moveTo 60 10
38-
lineTo 60 70
39-
lineTo 70 70
40-
closePath
43+
Shape.renderShape $ Shape.closedPath (foldr1 Shape.lineConnect (map Shape.pathPoint path))
4144
stroke
45+
46+
path :: [(Double, Double)]
47+
path = [(120, 10), (120, 40), (150, 30)]

‎src/Graphics/Declarative/Canvas/Shape.hs

Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
module Graphics.Declarative.Canvas.Shape where
2+
3+
import qualified Graphics.Rendering.Canvas as Canvas
4+
5+
import Graphics.Declarative.Border as Border
6+
import Graphics.Declarative.Bordered
7+
8+
import Linear
9+
10+
newtype Shape = Shape { renderShape :: Canvas.Canvas () }
11+
12+
circle :: Double -> Bordered Shape
13+
circle radius = Bordered (Border.circle radius) shape
14+
where shape = Shape $ Canvas.beginPath >> Canvas.arc 0 0 radius 0 (2*pi)
15+
16+
rectangle :: Double -> Double -> Bordered Shape
17+
rectangle width height = rectangleFromBB (V2 (-width/2) (-height/2), V2 (width/2) (height/2))
18+
19+
rectangleFromBB :: (V2 Double, V2 Double) -> Bordered Shape
20+
rectangleFromBB corners@(V2 l t, V2 r b) = Bordered (Border.fromBoundingBox corners) shape
21+
where
22+
shape = Shape $ Canvas.beginPath >> Canvas.rect l t (r-l) (b-t)
23+
24+
roundedRectangle :: Double -> Double -> Double -> Bordered Shape
25+
roundedRectangle radius width height = roundedRectangleFromBB radius (V2 0 0, V2 width height)
26+
27+
roundedRectangleFromBB :: Double -> (V2 Double, V2 Double) -> Bordered Shape
28+
roundedRectangleFromBB radius boundingBox@(V2 left up, V2 right down)
29+
| radius > width/2 || radius > height/2 = roundedRectangleFromBB (min (width/2) (height/2)) boundingBox
30+
| otherwise = Bordered hull $ Shape render
31+
where
32+
width = right-left
33+
height = down-up
34+
35+
innerLeft = left+radius
36+
innerUp = up+radius
37+
innerRight = right-radius
38+
innerDown = down-radius
39+
40+
hull = Border.padded radius $ Border.fromBoundingBox (V2 innerLeft innerUp, V2 innerRight innerDown)
41+
42+
degrees = (*) (pi / 180)
43+
44+
render = do
45+
Canvas.beginPath
46+
Canvas.arc innerLeft innerUp radius (degrees 180) (degrees 270)
47+
Canvas.arc innerRight innerUp radius (degrees 270) (degrees 0)
48+
Canvas.arc innerRight innerDown radius (degrees 0) (degrees 90)
49+
Canvas.arc innerLeft innerDown radius (degrees 90) (degrees 180)
50+
Canvas.closePath
51+
52+
53+
data Path = Path {
54+
pathStart :: (Double,Double),
55+
pathRenderer :: Canvas.Canvas ()
56+
}
57+
58+
renderOpenPath :: Path -> Canvas.Canvas ()
59+
renderOpenPath (Path start renderer) = Canvas.beginPath >> uncurry Canvas.moveTo start >> renderer
60+
61+
renderClosedPath :: Path -> Canvas.Canvas ()
62+
renderClosedPath path = Canvas.beginPath >> renderOpenPath path >> Canvas.closePath
63+
64+
65+
openPath :: Path -> Shape
66+
openPath = Shape . renderOpenPath
67+
68+
closedPath :: Path -> Shape
69+
closedPath = Shape . renderClosedPath
70+
71+
72+
pathPoint :: (Double,Double) -> Path
73+
pathPoint point = Path point (return ())
74+
75+
connectBy :: (Double -> Double -> Canvas.Canvas ())
76+
-> Path -> Path -> Path
77+
connectBy connector (Path start0 prim0) (Path start1 prim1)
78+
= Path start0 (prim0 >> connection >> prim1)
79+
where
80+
connection = uncurry connector start1
81+
82+
lineConnect :: Path -> Path -> Path
83+
lineConnect = connectBy Canvas.lineTo
84+
85+
curveConnect :: (Double,Double) -> (Double,Double)
86+
-> Path -> Path -> Path
87+
curveConnect (x1,y1) (x2,y2) = connectBy (Canvas.bezierCurveTo x1 y1 x2 y2)

‎src/Graphics/Declarative/Canvas/TangoColors.hs

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
module Graphics.Declarative.Canvas.TangoColors where
2+
3+
-- Stolen from Elm
4+
5+
6+
fromRGB (r,g,b) = (r/255, g/255, b/255)
7+
8+
lightRed = fromRGB (239,41,41)
9+
red = fromRGB (204,0,0)
10+
darkRed = fromRGB (164,0,0)
11+
12+
lightOrange = fromRGB (252,175,62)
13+
orange = fromRGB (245,121,0)
14+
darkOrange = fromRGB (206,92,0)
15+
16+
lightYellow = fromRGB (255,233,79)
17+
yellow = fromRGB (237,212,0)
18+
darkYellow = fromRGB (196,160,0)
19+
20+
lightGreen = fromRGB (138,226,52)
21+
green = fromRGB (115,210,22)
22+
darkGreen = fromRGB (78,154,6)
23+
24+
lightBlue = fromRGB (114,159,207)
25+
blue = fromRGB (52,101,164)
26+
darkBlue = fromRGB (32,74,135)
27+
28+
lightPurple = fromRGB (173,127,168)
29+
purple = fromRGB (117,80,123)
30+
darkPurple = fromRGB (92,53,102)
31+
32+
lightBrown = fromRGB (233,185,110)
33+
brown = fromRGB (193,125,17)
34+
darkBrown = fromRGB (143,89,2)
35+
36+
black = (0,0,0)
37+
white = (1,1,1)
38+
39+
lightGrey = fromRGB (238,238,236)
40+
grey = fromRGB (211,215,207)
41+
darkGrey = fromRGB (186,189,182)
42+
43+
lightGray = fromRGB (238,238,236)
44+
gray = fromRGB (211,215,207)
45+
darkGray = fromRGB (186,189,182)
46+
47+
lightCharcoal = fromRGB (136,138,133)
48+
charcoal = fromRGB (85,87,83)
49+
darkCharcoal = fromRGB (46,52,54)
50+
51+
52+
allColors =
53+
[lightRed
54+
,red
55+
,darkRed
56+
,lightOrange
57+
,orange
58+
,darkOrange
59+
,lightYellow
60+
,yellow
61+
,darkYellow
62+
,lightGreen
63+
,green
64+
,darkGreen
65+
,lightBlue
66+
,blue
67+
,darkBlue
68+
,lightPurple
69+
,purple
70+
,darkPurple
71+
,lightBrown
72+
,brown
73+
,darkBrown
74+
,black
75+
,white
76+
,lightGrey
77+
,grey
78+
,darkGrey
79+
,lightGray
80+
,gray
81+
,darkGray
82+
,lightCharcoal
83+
,charcoal
84+
,darkCharcoal
85+
]
86+
87+
88+
allColorsRandomOrder =
89+
[charcoal
90+
,red
91+
,brown
92+
,darkYellow
93+
,darkGrey
94+
,darkGreen
95+
,lightPurple
96+
,green
97+
,lightGreen
98+
,lightRed
99+
,purple
100+
,lightBrown
101+
,lightOrange
102+
,gray
103+
,darkOrange
104+
,blue
105+
,darkPurple
106+
,darkBrown
107+
,darkBlue
108+
,yellow
109+
,darkGray
110+
,orange
111+
,grey
112+
,darkRed
113+
,darkCharcoal
114+
]

‎src/Graphics/Rendering/Canvas.hs

Lines changed: 29 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,15 +15,21 @@ runCanvas canvas action = do
1515
ctx <- JS.getContextUnchecked canvas "2d" ([] :: [JS.JSString])
1616
runReaderT action (coerce ctx :: JS.CanvasRenderingContext2D)
1717

18+
save :: Canvas ()
19+
save = JS.save =<< ask
20+
21+
restore :: Canvas ()
22+
restore = JS.restore =<< ask
23+
1824
fillStyle :: String -> Canvas ()
1925
fillStyle style = do
2026
ctx <- ask
2127
JS.setFillStyle ctx style
2228

23-
fillRect :: Float -> Float -> Float -> Float -> Canvas ()
24-
fillRect x y w h = do
29+
rect :: Double -> Double -> Double -> Double -> Canvas ()
30+
rect x y w h = do
2531
ctx <- ask
26-
JS.fillRect ctx x y w h
32+
JS.rect ctx x y w h
2733

2834
fillText :: Float -> Float -> String -> Canvas ()
2935
fillText x y text = do
@@ -39,6 +45,11 @@ closePath = JS.closePath =<< ask
3945
stroke :: Canvas ()
4046
stroke = JS.stroke =<< ask
4147

48+
fill :: Canvas ()
49+
fill = do
50+
ctx <- ask
51+
JS.fill ctx Nothing
52+
4253
moveTo :: Double -> Double -> Canvas ()
4354
moveTo x y = do
4455
ctx <- ask
@@ -48,3 +59,18 @@ lineTo :: Double -> Double -> Canvas ()
4859
lineTo x y = do
4960
ctx <- ask
5061
JS.lineTo ctx x y
62+
63+
arc :: Double -> Double -> Double -> Double -> Double -> Canvas ()
64+
arc xc yc radius angle1 angle2 = do
65+
ctx <- ask
66+
JS.arc ctx xc yc radius angle1 angle2 False
67+
68+
quadraticCurveTo :: Double -> Double -> Double -> Double -> Canvas ()
69+
quadraticCurveTo x1 y1 x2 y2 = do
70+
ctx <- ask
71+
JS.quadraticCurveTo ctx x1 y1 x2 y2
72+
73+
bezierCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Canvas ()
74+
bezierCurveTo x1 y1 x2 y2 x3 y3 = do
75+
ctx <- ask
76+
JS.bezierCurveTo ctx x1 y1 x2 y2 x3 y3

0 commit comments

Comments
 (0)