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