
  0 | module Rhone.Canvas.Shape
  1 | 
  2 | import Control.Monad.Either.Extra
  3 | import Rhone.JS.Reactimate
  4 | import JS
  5 | import Rhone.Canvas.Angle
  6 | import Web.Html
  7 | 
  8 | %default total
  9 | 
 10 | --------------------------------------------------------------------------------
 11 | --          Types
 12 | --------------------------------------------------------------------------------
 13 | 
 14 | namespace PathType
 15 |   public export
 16 |   data PathType = Fill | Stroke
 17 | 
 18 | public export
 19 | data Segment : Type where
 20 |   Move  :  (x,y : Double) -> Segment
 21 |   Line  :  (x,y : Double) -> Segment
 22 |   Arc   :  (x,y,radius       : Double)
 23 |         -> (start,stop       : Angle)
 24 |         -> (counterclockwise : Bool)
 25 |         -> Segment
 26 |   ArcTo :  (x1,y1,x2,y2,radius : Double) -> Segment
 27 | 
 28 | namespace RectType
 29 |   public export
 30 |   data RectType = Fill | Stroke | Clear
 31 | 
 32 | public export
 33 | data Shape : Type where
 34 |   Rect   : (x,y,w,h : Double) -> RectType -> Shape
 35 |   Path   : List Segment -> PathType -> Shape
 36 |   Shapes : List Shape -> Shape
 37 |   Text   : String -> (x,y : Double) -> Optional Double -> Shape
 38 |   Text'  : String -> (x,y : Double) -> Shape
 39 | 
 40 | export
 41 | circle : (x,y,radius : Double) -> PathType -> Shape
 42 | circle x y r = Path [Arc x y r (rad 0) (rad $ 2 * pi) False]
 43 | 
 44 | export
 45 | polyLine : List (Double,Double) -> Shape
 46 | polyLine []           = Path [] Stroke
 47 | polyLine ((x,y) :: t) = Path (Move x y :: map (uncurry Line) t) Stroke
 48 | 
 49 | export
 50 | Semigroup Shape where
 51 |   x         <+> Shapes [] = x
 52 |   Shapes [] <+> y         = y
 53 |   Shapes xs <+> Shapes ys = Shapes $ xs ++ ys
 54 |   x         <+> Shapes ys = Shapes $ x :: ys
 55 |   x         <+> y         = Shapes [x,y]
 56 | 
 57 | export
 58 | Monoid Shape where
 59 |   neutral = Shapes []
 60 | 
 61 | --------------------------------------------------------------------------------
 62 | --          IO
 63 | --------------------------------------------------------------------------------
 64 | 
 65 | applySegment : CanvasRenderingContext2D -> Segment -> JSIO ()
 66 | applySegment ctxt (Move x y) = moveTo ctxt x y
 67 | applySegment ctxt (Line x y) = lineTo ctxt x y
 68 | applySegment ctxt (Arc x y r start stop ccw) = do
 69 |   arc' ctxt x y r (toRadians start) (toRadians stop) (Def ccw)
 70 | applySegment ctxt (ArcTo x1 y1 x2 y2 radius) =
 71 |   arcTo ctxt x1 y1 x2 y2 radius
 72 | 
 73 | export
 74 | applyAll : CanvasRenderingContext2D -> List Shape -> JSIO ()
 75 | 
 76 | export
 77 | apply : CanvasRenderingContext2D -> Shape -> JSIO ()
 78 | 
 79 | applyAll ctxt = assert_total $ traverseList_ (apply ctxt)
 80 | 
 81 | apply ctxt (Rect x y w h Fill)   = fillRect ctxt x y w h
 82 | apply ctxt (Rect x y w h Stroke) = strokeRect ctxt x y w h
 83 | apply ctxt (Rect x y w h Clear)  = clearRect ctxt x y w h
 84 | apply ctxt (Path ss st)          = do
 85 |   beginPath ctxt
 86 |   traverseList_ (applySegment ctxt) ss
 87 |   case st of
 88 |     Fill   => fill ctxt
 89 |     Stroke => stroke ctxt
 90 | apply ctxt (Text str x y max)    = fillText' ctxt str x y max
 91 | apply ctxt (Text' str x y)       = fillText ctxt str x y
 92 | apply ctxt (Shapes xs)           = applyAll ctxt xs
 93 |