clog/clog-canvas.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI                                 ;;;;
;;;; (c) 2020-2021 David Botton                                            ;;;;
;;;; License BSD 3 Clause                                                  ;;;;
;;;;                                                                       ;;;;
;;;; clog-canvas.lisp                                                      ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(cl:in-package :clog)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-canvas
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clog-canvas (clog-element)()
  (:documentation "CLOG Canvas Objects."))


;;;;;;;;;;;;;;;;;;;
;; create-canvas ;;
;;;;;;;;;;;;;;;;;;;

(defgeneric create-canvas (clog-obj &key width height auto-place)
  (:documentation "Create a new CLOG-Canvas as child of CLOG-OBJ if
:AUTO-PLACE (default t) place-inside-bottom-of CLOG-OBJ."))

(defmethod create-canvas ((obj clog-obj)
			  &key (width 300) (height 150) (auto-place t))
  (create-child obj (format nil "<canvas width=~A height=~A/>"
			    width height)
		:clog-type 'clog-canvas :auto-place auto-place))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-context2d
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clog-context2d (clog-obj)())

;;;;;;;;;;;;;;;;;;;;;;
;; create-context2d ;;
;;;;;;;;;;;;;;;;;;;;;;

(defgeneric create-context2d (clog-canvas)
  (:documentation "Create a new CLOG-Context2d from a CLOG-Canvas"))


(defmethod create-context2d ((obj clog-canvas))
  (let ((web-id (cc:generate-id)))
    (cc:execute (connection-id obj)
		(format nil "clog['~A']=clog['~A'].get(0).getContext('2d')"
			web-id
			(html-id obj)))
    
    (make-instance 'clog-context2d
		   :connection-id (connection-id obj)
		   :html-id web-id)))

;;clearRect
(defgeneric clear-rect (clog-context2d x y width height)
  (:documentation "Clear rectangle to transparent black"))

(defmethod clear-rect ((obj clog-context2d) x y width height)
  (execute obj (format nil "clearRect(~A,~A,~A,~A)"
		       x y width height)))

;;fillRect
(defgeneric fill-rect (clog-context2d x y width height)
  (:documentation "Fill rectangle with current fill-color"))

(defmethod fill-rect ((obj clog-context2d) x y width height)
  (execute obj (format nil "fillRect(~A,~A,~A,~A)"
		       x y width height)))

;;strokeRect
(defgeneric stroke-rect (clog-context2d x y width height)
  (:documentation "Fill rectangle using current stroke-style"))

(defmethod stroke-rect ((obj clog-context2d) x y width height)
  (execute obj (format nil "strokeRect(~A,~A,~A,~A)"
		       x y width height)))

;;fillText
(defgeneric fill-text (clog-context2d text x y &key max-width)
  (:documentation "Fill text with current fill-color"))

(defmethod fill-text ((obj clog-context2d) text x y &key (max-width nil))
  (execute obj (format nil "fillText('~A',~A,~A~A)"
		       (escape-string text)
		       x y
		       (if max-width
			   (format nil ",~A" max-width)
			   ""))))
;;strokeText
(defgeneric stroke-text (clog-context2d text x y &key max-width)
  (:documentation "Stroke text with current stroke-style"))

(defmethod stroke-text ((obj clog-context2d) text x y &key (max-width nil))
  (execute obj (format nil "strokeText('~A',~A,~A~A)"
		       (escape-string text)
		       x y
		       (if max-width
			   (format nil ",~A" max-width)
			   ""))))
;;measureText
(defgeneric measure-text (clog-context2d text)
  (:documentation "Measure text"))

(defmethod measure-text ((obj clog-context2d) text)
  ;; (let ((text-metric (query obj
  ;;(format nil "measureText('~A')" (escape-string text)))))
    ;; needs way to query like for events
    )

;;lineWidth
(defgeneric line-width (clog-context2d value)
  (:documentation "Set line style width"))

(defmethod line-width ((obj clog-context2d) value)
  (execute obj (format nil "lineWidth=~A" value)))

;;lineCap
(deftype line-cap-type () '(member :butt :round :square))

(defgeneric line-cap (clog-context2d value)
  (:documentation "Set line cap style"))

(defmethod line-cap ((obj clog-context2d) value)
  (execute obj (format nil "lineCap='~A'" value)))

;;lineJoin
(deftype line-join-type () '(member :bevel :round :miter))

(defgeneric line-join (clog-context2d value)
  (:documentation "Set line join style"))

(defmethod line-join ((obj clog-context2d) value)
  (execute obj (format nil "lineJoin='~A'" value)))

;;miterLimit
(defgeneric miter-limit (clog-context2d value)
  (:documentation "Set miter style limit"))

(defmethod miter-limit ((obj clog-context2d) value)
  (execute obj (format nil "miterLimit=~A" value)))

;;getLineDash
(defgeneric get-line-dash (clog-context2d)
  (:documentation "Set line style dash pattern, e.g. [10, 20]"))

(defmethod get-line-dash ((obj clog-context2d))
  (query obj (format nil "getLineDash()")))

;;setLineDash
(defgeneric set-line-dash (clog-context2d value)
  (:documentation "Set line style dash pattern, e.g. [10, 20]"))

(defmethod set-line-dash ((obj clog-context2d) value)
  (execute obj (format nil "setLineDash(~A)" value)))

;;lineDashOffset
(defgeneric line-dash-offset (clog-context2d value)
  (:documentation "Set miter style limit"))

(defmethod line-dash-offset ((obj clog-context2d) value)
  (execute obj (format nil "lineDashOffset=~A" value)))

;;font-style
(defgeneric font-style (clog-context2d value)
  (:documentation "Set font style using css font string
     https://developer.mozilla.org/en-US/docs/Web/CSS/font"))

(defmethod font-style ((obj clog-context2d) value)
  (execute obj (format nil "font='~A'" value)))

;;textAlign
(deftype text-align-type () '(member :left :right :center :start :end))

(defgeneric text-align (clog-context2d value)
  (:documentation "Set text alignment style"))

(defmethod text-align ((obj clog-context2d) value)
  (execute obj (format nil "textAlign='~A'" value)))

;;textBaseline
(deftype text-baseline-type ()
  '(member :top :hanging :middle :alphabetic :ideographic :bottom))

(defgeneric text-baseline (clog-context2d value)
  (:documentation "Set text baseline style"))

(defmethod text-baseline ((obj clog-context2d) value)
  (execute obj (format nil "textBaseline='~A'" value)))

;;direction
(defgeneric text-dir (clog-context2d value)
  (:documentation "Set text direction style"))

(defmethod text-dir ((obj clog-context2d) value)
  (execute obj (format nil "direction='~A'" value)))

;;fillStyle
(defgeneric fill-style (clog-context2d value)
  (:documentation "Set text direction style"))

(defmethod fill-style ((obj clog-context2d) value)
  (execute obj (format nil "fillStyle='~A'" value)))

;;strokeStyle
(defgeneric stroke-style (clog-context2d value)
  (:documentation "Set text stroke style"))

(defmethod stroke-style ((obj clog-context2d) value)
  (execute obj (format nil "strokeStyle='~A'" value)))

;; need to add createLinearGradient
;; need to add createRadialGradient
;; need to add createPattern

;;shadowBlur
(defgeneric shadow-blur (clog-context2d value)
  (:documentation "Set text shadow blur"))

(defmethod shadow-blur ((obj clog-context2d) value)
  (execute obj (format nil "shadowBlur='~A'" value)))

;;shadowColor
(defgeneric shadow-color (clog-context2d value)
  (:documentation "Set text shadow color"))

(defmethod shadow-color ((obj clog-context2d) value)
  (execute obj (format nil "shadowColor='~A'" value)))

;;shadowOffsetX
(defgeneric shadow-offset-x (clog-context2d value)
  (:documentation "Set text shadow offset x"))

(defmethod shadow-offset-x ((obj clog-context2d) value)
  (execute obj (format nil "shadowOffsetX='~A'" value)))

;;shadowOffsetY
(defgeneric shadow-offset-y (clog-context2d value)
  (:documentation "Set text shadow offset y"))

(defmethod shadow-offset-y ((obj clog-context2d) value)
  (execute obj (format nil "shadowOffsetY='~A'" value)))

;;beginPath()
(defgeneric begin-path (clog-context2d)
  (:documentation "Starts a new path empting any previous points."))

(defmethod begin-path ((obj clog-context2d))
  (execute obj "beginPath()"))

;;closePath()
(defgeneric close-path (clog-context2d)
  (:documentation "Adds a line to start point of path."))

(defmethod close-path ((obj clog-context2d))
  (execute obj "closePath()"))

;;moveTo()
(defgeneric move-to (clog-context2d x y)
  (:documentation "Moves start point of path."))

(defmethod move-to ((obj clog-context2d) x y)
  (execute obj (format nil "moveTo(~A,~A)" x y)))

;;lineTo()
(defgeneric line-to (clog-context2d x y)
  (:documentation "Adds a line to the current path."))

(defmethod line-to ((obj clog-context2d) x y)
  (execute obj (format nil "lineTo(~A,~A)" x y)))

;;bezierCurveTo()
(defgeneric bezier-curve-to (clog-context2d cp1x cp1y cp2x cp2y x y)
  (:documentation "Adds a cubic Bezier curve to the current path."))

(defmethod bezier-curve-to ((obj clog-context2d) cp1x cp1y cp2x cp2y x y)
  (execute obj (format nil "bezierCurveTo(~A,~A,~A,~A,~A,~A)"
		       cp1x cp1y cp2x cp2y x y)))

;;quadraticCurveTo()
(defgeneric quadratic-curve-to (clog-context2d cpx cpy x y)
  (:documentation "Adds a quadratic Bezier curve to the current path."))

(defmethod quadratic-curve-to ((obj clog-context2d) cpx cpy x y)
  (execute obj (format nil "quadraticCurveTo(~A,~A,~A,~A)" cpx cpy x y)))

;;arc()
(defgeneric arc (clog-context2d x y radius start-angle end-angle
		 &key anticlockwise)
  (:documentation "Adds a circular arc to the current path."))

(defmethod arc ((obj clog-context2d) x y radius start-angle end-angle
		&key (anticlockwise nil))
  (execute obj (format nil "arc(~A,~A,~A,~A,~A~A)"
		       x y radius start-angle end-angle
		       (if anticlockwise
			   (format nil ",~A" anticlockwise)
			   ""))))
;;arcTo()
(defgeneric arc-to (clog-context2d x1 y1 x2 y2)
  (:documentation "Adds an arc to the current path."))

(defmethod arc-to ((obj clog-context2d) x1 y1 x2 y2)
  (execute obj (format nil "arcTo(~A,~A,~A,~A)" x1 y1 x2 y2)))

;;ellipse()
(defgeneric ellipse (clog-context2d x y radius-x radius-y rotation
		     start-angle end-angle
		     &key anticlockwise)
  (:documentation "Adds an elliptical arc to the current path."))

(defmethod ellipse ((obj clog-context2d) x y radius-x radius-y rotation
		    start-angle end-angle
		    &key (anticlockwise nil))
  (execute obj (format nil "ellipse(~A,~A,~A,~A,~A,~A,~A~A)"
		       x y radius-x radius-y rotation start-angle end-angle
		       (if anticlockwise
			   (format nil ",~A" anticlockwise)
			   ""))))

;;rect()
(defgeneric rect (clog-context2d x y width height)
  (:documentation "Adds a rectangle to the current path."))

(defmethod rect ((obj clog-context2d) x y width height)
  (execute obj (format nil "rect(~A,~A,~A,~A)" x y width height)))

;;fill()
(defgeneric path-fill (clog-context2d)
  (:documentation "Fill a path."))

(defmethod path-fill ((obj clog-context2d))
  (execute obj "fill()"))

;;stroke()
(defgeneric path-stroke (clog-context2d)
  (:documentation "Stroke a path."))

(defmethod path-stroke ((obj clog-context2d))
  (execute obj "stroke()"))

;;clip()
(defgeneric path-clip (clog-context2d)
  (:documentation "Clip a path."))

(defmethod path-clip ((obj clog-context2d))
  (execute obj "clip()"))

;;save()
(defgeneric canvas-save (clog-context2d)
  (:documentation "Save canvas to stack"))

(defmethod canvas-save ((obj clog-context2d))
  (execute obj "save()"))

;;restore()
(defgeneric canvas-restore (clog-context2d)
  (:documentation "Restore canvas from stack"))

(defmethod canvas-restore ((obj clog-context2d))
  (execute obj "restore()"))