(in-package :graphic-forms.uitoolkit.graphics)

;;;
;;; helper functions
;;;

(defun compute-pen-style (style width)
  (let ((main-styles (list (cons :alternate  gfs::+ps-alternate+)
                           (cons :dash       gfs::+ps-dash+)
                           (cons :dashdotdot gfs::+ps-dashdotdot+)
                           (cons :dot        gfs::+ps-dot+)
                           (cons :solid      gfs::+ps-solid+)))
        (endcap-styles (list (cons :flat-endcap   gfs::+ps-endcap-flat+)
                             (cons :round-endcap  gfs::+ps-endcap-round+)
                             (cons :square-endcap gfs::+ps-endcap-square+)))
        (join-styles (list (cons :bevel-join gfs::+ps-join-bevel+)
                           (cons :miter-join gfs::+ps-join-miter+)
                           (cons :round-join gfs::+ps-join-round+)))
        (native-style (if (> width 1) gfs::+ps-geometric+ gfs::+ps-cosmetic+))
        (tmp nil))
    (if (null style)
      (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+)))
    (setf tmp (intersection style (mapcar #'first main-styles)))
    (if (/= (length tmp) 1)
      (error 'gfs:toolkit-error :detail "main pen style keyword [:alternate | :dash | :dashdotdot | :dot | :solid] is required"))
    (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles))))
    (setf tmp (intersection style (mapcar #'first endcap-styles)))
    (if (> (length tmp) 1)
      (error 'gfs:toolkit-error :detail "only one end cap pen style keyword [:flat-endcap | :round-endcap | :square-endcap] is allowed"))
    (setf native-style (logior native-style (if tmp
                                              (cdr (assoc (car tmp) endcap-styles)) 0)))
    (unless (null tmp)
      (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+))
                                 gfs::+ps-geometric+)))
    (setf tmp (intersection style (mapcar #'first join-styles)))
    (if (> (length tmp) 1)
      (error 'gfs:toolkit-error :detail "only one join pen style keyword [:bevel-join | :miter-join | :round-join] is allowed"))
    (setf native-style (logior native-style (if tmp
                                              (cdr (assoc (car tmp) join-styles)) 0)))
    (unless (null tmp)
      (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+))
                         gfs::+ps-geometric+)))
    native-style))

(defun update-pen-for-gc (gc)
  (cffi:with-foreign-object (lb-ptr '(:struct gfs::logbrush))
    (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr (:struct gfs::logbrush))
      (setf gfs::style (logbrush-style-of gc))
      (setf gfs::color (logbrush-color-of gc))
      (setf gfs::hatch (logbrush-hatch-of gc))
      (let ((old-hpen (cffi:null-pointer))
            (new-hpen (gfs::ext-create-pen (compute-pen-style (pen-style gc) (pen-width gc))
                                           (pen-width gc)
                                           lb-ptr 0
                                           (cffi:null-pointer))))
        (if (gfs:null-handle-p new-hpen)
          (error 'gfs:win32-error :detail "ext-create-pen failed"))
        (setf (pen-handle-of gc) new-hpen)
        (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen))
        (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer))
        (unless (gfs:null-handle-p old-hpen)
          (gfs::delete-object old-hpen))))))

(defun call-rect-function (fn name hdc rect)
  (let ((pnt (gfs:location rect))
        (size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x pnt)
                        (gfs:point-y pnt)
                        (+ (gfs:point-x pnt) (gfs:size-width size))
                        (+ (gfs:point-y pnt) (gfs:size-height size))))
      (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))

(defun call-rounded-rect-function (fn name hdc rect arc-size)
  (let ((pnt (gfs:location rect))
        (size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x pnt)
                        (gfs:point-y pnt)
                        (+ (gfs:point-x pnt) (gfs:size-width size))
                        (+ (gfs:point-y pnt) (gfs:size-height size))
                        (gfs:size-width arc-size)
                        (gfs:size-height arc-size)))
      (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))

(defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt)
  (let ((rect-pnt (gfs:location rect))
        (rect-size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x rect-pnt)
                        (gfs:point-y rect-pnt)
                        (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size))
                        (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size))
                        (gfs:point-x start-pnt)
                        (gfs:point-y start-pnt)
                        (gfs:point-x end-pnt)
                        (gfs:point-y end-pnt)))
      (error 'gfs:win32-error :detail (format nil "~a failed" name)))))

(defun call-points-function (fn name hdc points)
  (let* ((count (length points))
         (array (cffi:foreign-alloc '(:struct gfs::point) :count count)))
    (unwind-protect
        (progn
          (loop for pnt in points
                with i = 0
                do (progn
                     (cffi:with-foreign-slots ((gfs::x gfs::y)
                                               (cffi:mem-aptr array '(:struct gfs::point) i) (:struct gfs::point))
                       (setf gfs::x (gfs:point-x pnt))
                       (setf gfs::y (gfs:point-y pnt)))
                     (incf i)))
          (if (zerop (funcall fn hdc array count))
            (error 'gfs:win32-error :detail (format nil "~a failed" name))))
      (cffi:foreign-free array))))

(defun compute-draw-text-style (style)
  (let ((flags (logior gfs::+dt-noclip+ gfs::+dt-noprefix+ gfs::+dt-singleline+ gfs::+dt-vcenter+)))
    (unless (null style)
      (loop for sym in style
            do (cond
                 ((eq sym :mnemonic)
                    (setf flags (logand flags (lognot gfs::+dt-noprefix+))))
                 ((eq sym :tab)
                    (setf flags (logior flags gfs::+dt-expandtabs+)))
                  ;; FIXME: the :transparent style needs to be implemented
                  ;;
                 ((eq sym :transparent)))))
    flags))

(defun text-bounds (hdc str dt-flags tab-width)
  (let ((len (length str))
        (sz (gfs:make-size)))
    (when (> len 0)
      (cffi:with-foreign-object (dt-ptr '(:struct gfs::drawtextparams))
        (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin)
                                  dt-ptr (:struct gfs::drawtextparams))
          (setf gfs::cbsize (cffi:foreign-type-size '(:struct gfs::drawtextparams)))
          (setf gfs::tablength tab-width)
          (setf gfs::leftmargin 0)
          (setf gfs::rightmargin 0)
          (gfs::with-rect (rect-ptr)
            (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
            (setf (gfs:size-width sz) (- gfs::right gfs::left))
            (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))
    (when (or (zerop len) (zerop (gfs:size-height sz)))
      (cffi:with-foreign-object (tm-ptr '(:struct gfs::textmetrics))
        (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr (:struct gfs::textmetrics))
          (if (zerop (gfs::get-text-metrics hdc tm-ptr))
            (error 'gfs:win32-error :detail "get-text-metrics failed"))
          (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading)))))
    sz))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro with-null-brush ((gc) &body body)
    (let ((hdc (gensym))
          (tmp-hbr (gensym))
          (orig-hbr (gensym)))
      `(let* ((,hdc (gfs:handle ,gc))
              (,tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
              (,orig-hbr (gfs::select-object ,hdc ,tmp-hbr)))
         (unwind-protect
             (progn
               ,@body)
           (gfs::select-object ,hdc ,orig-hbr))))))

;;;
;;; methods
;;;

(defmethod background-color ((self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (rgb->color (gfs::get-bk-color (gfs:handle self))))

(defmethod (setf background-color) ((clr color) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((hdc (gfs:handle self))
        (hbrush (gfs::get-stock-object gfs::+dc-brush+))
        (rgb (color->rgb clr)))
    (gfs::select-object hdc hbrush)
    (gfs::set-dc-brush-color hdc rgb)
    (gfs::set-bk-color hdc rgb)))

(defmethod clear ((self graphics-context) (color color))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (background-color self) color
        (foreground-color self) color)
  (let ((hdc (gfs:handle self))
        (size (surface-size-of self)))
    (if size
            (gfs::with-rect (rect-ptr)
              (setf gfs::top    0
                    gfs::left   0
              gfs::right  (gfs:size-width size)
              gfs::bottom (gfs:size-height size))
        (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer)))
      (warn 'gfs:toolkit-warning :detail "null surface size"))))

(defmethod gfs:dispose ((self graphics-context))
  (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+))
  (gfs::delete-object (pen-handle-of self))
  (setf (pen-handle-of self) nil)
  (let ((fn (dc-destructor-of self)))
    (unless (null fn)
      (if (null (widget-handle-of self))
        (funcall fn (gfs:handle self))
        (funcall fn (widget-handle-of self) (gfs:handle self)))))
  (setf (surface-size-of self) nil)
  (setf (widget-handle-of self) nil)
  (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))

(defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-bezier ((self graphics-context) start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-points-function #'gfs::poly-bezier
                        "poly-bezier"
                        (gfs:handle self)
                        (list start-pnt ctrl-pnt-1 ctrl-pnt-2 end-pnt)))

(defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt)))

(defmethod draw-ellipse ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)))

(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-filled-ellipse ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))

(defmethod draw-filled-pie-wedge ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-filled-polygon ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 3)
    (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))

(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
  (if (gfs:disposed-p self)
      (error 'gfs:disposed-error))
   ( clim - gf::debug - prin1 " draw - filled - rect " self rect ) 
  (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))

(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))

;;;
;;; TODO: support addressing elements within bitmap as if it were an array
;;;
(defmethod draw-image ((self graphics-context) (im image) (pnt gfs:point))
   ( clim - gf::debug - prin1 " draw - image " self i m ) 
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (if (gfs:disposed-p im)
    (error 'gfs:disposed-error))
  (let ((gc-dc (gfs:handle self))
        (himage (gfs:handle im))
        (tr-mask nil)
        (memdc (gfs::create-compatible-dc (cffi:null-pointer))))
    (cffi:with-foreign-object (bmp-ptr '(:struct gfs::bitmap))
      (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr (:struct gfs::bitmap))
        (gfs::get-object himage (cffi:foreign-type-size '(:struct gfs::bitmap)) bmp-ptr)
        (if (transparency-pixel-of im)
          (progn
            (setf tr-mask (transparency-mask im))
            (let ((hmask (gfs:handle tr-mask))
                  (hcopy (clone-bitmap himage))
                  (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))
                  (black (make-color :red 0 :green 0 :blue 0))
                  (white (make-color :red #xFF :green #xFF :blue #xFF)))
              (gfs::select-object memdc hmask)
              (gfs::select-object memdc2 hcopy)
              (gfs::set-bk-color memdc2 (color->rgb black))
              (gfs::set-text-color memdc2 (color->rgb white))
              (gfs::bit-blt memdc2
                            0 0
                            gfs::width
                            gfs::height
                            memdc
                            0 0 gfs::+blt-srcand+)
              (gfs::bit-blt gc-dc
                            (gfs:point-x pnt)
                            (gfs:point-y pnt)
                            gfs::width
                            gfs::height
                            memdc
                            0 0 gfs::+blt-srcand+)
              (gfs::bit-blt gc-dc
                            (gfs:point-x pnt)
                            (gfs:point-y pnt)
                            gfs::width
                            gfs::height
                            memdc2
                            0 0 gfs::+blt-srcpaint+)
              (gfs::delete-dc memdc2)
              (gfs::delete-object hcopy))
            (gfs:dispose tr-mask))
          (progn
            (gfs::select-object memdc himage)
            (gfs::bit-blt gc-dc
                          (gfs:point-x pnt)
                          (gfs:point-y pnt)
                          gfs::width
                          gfs::height
                          memdc
                          0 0 gfs::+blt-srccopy+)))))
    (gfs::delete-dc memdc)))

(defmethod draw-line ((self graphics-context) start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt)))

(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt)))

(defmethod draw-point ((self graphics-context) pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (gfs::set-pixel (gfs:handle self)
                  (gfs:point-x pnt)
                  (gfs:point-y pnt)
                  (color->rgb (foreground-color self))))

(defmethod draw-poly-bezier ((self graphics-context) start-pnt points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (null points)
    (let ((tmp (loop for triplet in points
                     append (list (second triplet) (third triplet) (first triplet)))))
      (push start-pnt tmp)
      (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp))))

(defmethod draw-polygon ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 3)
    (with-null-brush (self)
      (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points))))

(defmethod draw-polyline ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 2)
    (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points)))

(defmethod draw-rectangle ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)))

(defmethod draw-rounded-rectangle ((self graphics-context) rect size)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size)))

(defmethod draw-text ((self graphics-context) text (pnt gfs:point) &optional style tab-width)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((flags (compute-draw-text-style style))
        (tb-width (if (null tab-width) 0 tab-width))
        (old-bk-mode (gfs::get-bk-mode (gfs:handle self))))
    (if (find :transparent style)
      (gfs::set-bk-mode (gfs:handle self) gfs::+transparent+))
    (cffi:with-foreign-object (dt-ptr '(:struct gfs::drawtextparams))
      (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin)
                                dt-ptr (:struct gfs::drawtextparams))
        (setf gfs::cbsize (cffi:foreign-type-size '(:struct gfs::drawtextparams)))
        (setf gfs::tablength tb-width)
        (setf gfs::leftmargin 0)
        (setf gfs::rightmargin 0)
        (gfs::with-rect (rect-ptr)
          (setf gfs::left (gfs:point-x pnt))
          (setf gfs::top (gfs:point-y pnt))
          (gfs::draw-text-ex (gfs:handle self)
                             text
                             -1
                             rect-ptr
                             (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+)))
                             dt-ptr)
          (gfs::draw-text-ex (gfs:handle self)
                             text
                             (length text)
                             rect-ptr
                             flags
                             dt-ptr)
          (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))

(defmethod (setf font) ((font font) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (gfs::select-object (gfs:handle self) (gfs:handle font)))

(defmethod foreground-color ((self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (rgb->color (gfs::get-text-color (gfs:handle self))))

(defmethod (setf foreground-color) ((clr color) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((rgb (color->rgb clr)))
    (gfs::set-text-color (gfs:handle self) rgb)
    (setf (logbrush-color-of self) rgb)
    (update-pen-for-gc self)))

(defmethod initialize-instance :after ((self graphics-context) &key image widget &allow-other-keys)
  (when (null (gfs:handle self))
    (let ((hdc (cffi:null-pointer)))
      (if (null widget)
        (progn
          (setf hdc (gfs::create-compatible-dc (cffi:null-pointer)))
          (setf (dc-destructor-of self) #'gfs::delete-dc))
        (progn
          (setf hdc (gfs::get-dc (gfs:handle widget)))
          (setf (dc-destructor-of self) #'gfs::release-dc)
          (setf (widget-handle-of self) (gfs:handle widget))
          (setf (surface-size-of self) (gfw:client-size widget))))
      (setf (slot-value self 'gfs:handle) hdc)
      (unless (null image)
        (setf (surface-size-of self) (gfg:size image))
        (gfs::select-object hdc (gfs:handle image)))))
  ;; ensure world-to-device transformation conformance
  (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+)
  (update-pen-for-gc self))

(defmethod metrics ((self graphics-context) (font font))
  (if (or (gfs:disposed-p self) (gfs:disposed-p font))
    (error 'gfs:disposed-error))
  (let ((hdc (gfs:handle self))
        (hfont (gfs:handle font))
        (metrics nil))
    (gfs::with-hfont-selected (hdc hfont)
      (cffi:with-foreign-object (tm-ptr '(:struct gfs::textmetrics))
        (cffi:with-foreign-slots ((gfs::tmascent gfs::tmdescent gfs::tmexternalleading
                                   gfs::tmavgcharwidth gfs::tmmaxcharwidth)
                                  tm-ptr (:struct gfs::textmetrics))
          (if (zerop (gfs::get-text-metrics hdc tm-ptr))
            (error 'gfs:win32-error :detail "get-text-metrics failed"))
          (setf metrics (make-font-metrics :ascent gfs::tmascent
                                           :descent gfs::tmdescent
                                           :leading gfs::tmexternalleading
                                           :avg-char-width gfs::tmavgcharwidth
                                           :max-char-width gfs::tmmaxcharwidth)))))
    metrics))

(defmethod (setf pen-style) :around (style (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (slot-value self 'pen-style) style)
  (update-pen-for-gc self))

(defmethod (setf pen-width) :around (width (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (slot-value self 'pen-width) width)
  (update-pen-for-gc self))

(defmethod text-extent ((self graphics-context) str &optional style tab-width)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (text-bounds (gfs:handle self)
               str
               (compute-draw-text-style style)
               (if (or (null tab-width) (< tab-width 0)) 0 tab-width)))

(defun create-rect-region (vec)
  (apply 'gfs::create-rect-rgn (coerce vec 'list)))

(defmethod set-clipping-region ((self graphics-context) (clipping-region vector))
  (if (zerop (length clipping-region))
      (let ((rgn (create-rect-region #(0 0 0 0))))
	(gfs::select-clip-rgn (gfs:handle self) rgn)
	(gfs::delete-object rgn))
      (let ((rgn (create-rect-region clipping-region)))
	(gfs::select-clip-rgn (gfs:handle self) rgn)
	(gfs::delete-object rgn))))

(defmethod set-clipping-region ((self graphics-context) (clipping-region list))
  (assert clipping-region)
  (let ((rgn (create-rect-region (first clipping-region))))
    (gfs::select-clip-rgn (gfs:handle self) rgn)
    (gfs::delete-object rgn)
    (loop for tmp in (cdr clipping-region)
       for rgn = (create-rect-region tmp)
       do (progn
	    (gfs::ext-select-clip-rgn (gfs:handle self) rgn gfs::+rgn-or+)
	    (gfs::delete-object rgn)))))

(defmethod set-mix-mode ((self graphics-context) mix-mode)
  (gfs::set-rop2 (gfs:handle self) mix-mode))


 helper functions

 FIXME: the :transparent style needs to be implemented


 methods


 TODO: support addressing elements within bitmap as if it were an array

 ensure world-to-device transformation conformance

(in-package :graphic-forms.uitoolkit.graphics)


(defun compute-pen-style (style width)
  (let ((main-styles (list (cons :alternate  gfs::+ps-alternate+)
                           (cons :dash       gfs::+ps-dash+)
                           (cons :dashdotdot gfs::+ps-dashdotdot+)
                           (cons :dot        gfs::+ps-dot+)
                           (cons :solid      gfs::+ps-solid+)))
        (endcap-styles (list (cons :flat-endcap   gfs::+ps-endcap-flat+)
                             (cons :round-endcap  gfs::+ps-endcap-round+)
                             (cons :square-endcap gfs::+ps-endcap-square+)))
        (join-styles (list (cons :bevel-join gfs::+ps-join-bevel+)
                           (cons :miter-join gfs::+ps-join-miter+)
                           (cons :round-join gfs::+ps-join-round+)))
        (native-style (if (> width 1) gfs::+ps-geometric+ gfs::+ps-cosmetic+))
        (tmp nil))
    (if (null style)
      (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+)))
    (setf tmp (intersection style (mapcar #'first main-styles)))
    (if (/= (length tmp) 1)
      (error 'gfs:toolkit-error :detail "main pen style keyword [:alternate | :dash | :dashdotdot | :dot | :solid] is required"))
    (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles))))
    (setf tmp (intersection style (mapcar #'first endcap-styles)))
    (if (> (length tmp) 1)
      (error 'gfs:toolkit-error :detail "only one end cap pen style keyword [:flat-endcap | :round-endcap | :square-endcap] is allowed"))
    (setf native-style (logior native-style (if tmp
                                              (cdr (assoc (car tmp) endcap-styles)) 0)))
    (unless (null tmp)
      (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+))
                                 gfs::+ps-geometric+)))
    (setf tmp (intersection style (mapcar #'first join-styles)))
    (if (> (length tmp) 1)
      (error 'gfs:toolkit-error :detail "only one join pen style keyword [:bevel-join | :miter-join | :round-join] is allowed"))
    (setf native-style (logior native-style (if tmp
                                              (cdr (assoc (car tmp) join-styles)) 0)))
    (unless (null tmp)
      (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+))
                         gfs::+ps-geometric+)))
    native-style))

(defun update-pen-for-gc (gc)
  (cffi:with-foreign-object (lb-ptr '(:struct gfs::logbrush))
    (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr (:struct gfs::logbrush))
      (setf gfs::style (logbrush-style-of gc))
      (setf gfs::color (logbrush-color-of gc))
      (setf gfs::hatch (logbrush-hatch-of gc))
      (let ((old-hpen (cffi:null-pointer))
            (new-hpen (gfs::ext-create-pen (compute-pen-style (pen-style gc) (pen-width gc))
                                           (pen-width gc)
                                           lb-ptr 0
                                           (cffi:null-pointer))))
        (if (gfs:null-handle-p new-hpen)
          (error 'gfs:win32-error :detail "ext-create-pen failed"))
        (setf (pen-handle-of gc) new-hpen)
        (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen))
        (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer))
        (unless (gfs:null-handle-p old-hpen)
          (gfs::delete-object old-hpen))))))

(defun call-rect-function (fn name hdc rect)
  (let ((pnt (gfs:location rect))
        (size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x pnt)
                        (gfs:point-y pnt)
                        (+ (gfs:point-x pnt) (gfs:size-width size))
                        (+ (gfs:point-y pnt) (gfs:size-height size))))
      (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))

(defun call-rounded-rect-function (fn name hdc rect arc-size)
  (let ((pnt (gfs:location rect))
        (size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x pnt)
                        (gfs:point-y pnt)
                        (+ (gfs:point-x pnt) (gfs:size-width size))
                        (+ (gfs:point-y pnt) (gfs:size-height size))
                        (gfs:size-width arc-size)
                        (gfs:size-height arc-size)))
      (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))

(defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt)
  (let ((rect-pnt (gfs:location rect))
        (rect-size (gfs:size rect)))
    (if (zerop (funcall fn
                        hdc
                        (gfs:point-x rect-pnt)
                        (gfs:point-y rect-pnt)
                        (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size))
                        (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size))
                        (gfs:point-x start-pnt)
                        (gfs:point-y start-pnt)
                        (gfs:point-x end-pnt)
                        (gfs:point-y end-pnt)))
      (error 'gfs:win32-error :detail (format nil "~a failed" name)))))

(defun call-points-function (fn name hdc points)
  (let* ((count (length points))
         (array (cffi:foreign-alloc '(:struct gfs::point) :count count)))
    (unwind-protect
        (progn
          (loop for pnt in points
                with i = 0
                do (progn
                     (cffi:with-foreign-slots ((gfs::x gfs::y)
                                               (cffi:mem-aptr array '(:struct gfs::point) i) (:struct gfs::point))
                       (setf gfs::x (gfs:point-x pnt))
                       (setf gfs::y (gfs:point-y pnt)))
                     (incf i)))
          (if (zerop (funcall fn hdc array count))
            (error 'gfs:win32-error :detail (format nil "~a failed" name))))
      (cffi:foreign-free array))))

(defun compute-draw-text-style (style)
  (let ((flags (logior gfs::+dt-noclip+ gfs::+dt-noprefix+ gfs::+dt-singleline+ gfs::+dt-vcenter+)))
    (unless (null style)
      (loop for sym in style
            do (cond
                 ((eq sym :mnemonic)
                    (setf flags (logand flags (lognot gfs::+dt-noprefix+))))
                 ((eq sym :tab)
                    (setf flags (logior flags gfs::+dt-expandtabs+)))
                 ((eq sym :transparent)))))
    flags))

(defun text-bounds (hdc str dt-flags tab-width)
  (let ((len (length str))
        (sz (gfs:make-size)))
    (when (> len 0)
      (cffi:with-foreign-object (dt-ptr '(:struct gfs::drawtextparams))
        (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin)
                                  dt-ptr (:struct gfs::drawtextparams))
          (setf gfs::cbsize (cffi:foreign-type-size '(:struct gfs::drawtextparams)))
          (setf gfs::tablength tab-width)
          (setf gfs::leftmargin 0)
          (setf gfs::rightmargin 0)
          (gfs::with-rect (rect-ptr)
            (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
            (setf (gfs:size-width sz) (- gfs::right gfs::left))
            (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))
    (when (or (zerop len) (zerop (gfs:size-height sz)))
      (cffi:with-foreign-object (tm-ptr '(:struct gfs::textmetrics))
        (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr (:struct gfs::textmetrics))
          (if (zerop (gfs::get-text-metrics hdc tm-ptr))
            (error 'gfs:win32-error :detail "get-text-metrics failed"))
          (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading)))))
    sz))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro with-null-brush ((gc) &body body)
    (let ((hdc (gensym))
          (tmp-hbr (gensym))
          (orig-hbr (gensym)))
      `(let* ((,hdc (gfs:handle ,gc))
              (,tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
              (,orig-hbr (gfs::select-object ,hdc ,tmp-hbr)))
         (unwind-protect
             (progn
               ,@body)
           (gfs::select-object ,hdc ,orig-hbr))))))


(defmethod background-color ((self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (rgb->color (gfs::get-bk-color (gfs:handle self))))

(defmethod (setf background-color) ((clr color) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((hdc (gfs:handle self))
        (hbrush (gfs::get-stock-object gfs::+dc-brush+))
        (rgb (color->rgb clr)))
    (gfs::select-object hdc hbrush)
    (gfs::set-dc-brush-color hdc rgb)
    (gfs::set-bk-color hdc rgb)))

(defmethod clear ((self graphics-context) (color color))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (background-color self) color
        (foreground-color self) color)
  (let ((hdc (gfs:handle self))
        (size (surface-size-of self)))
    (if size
            (gfs::with-rect (rect-ptr)
              (setf gfs::top    0
                    gfs::left   0
              gfs::right  (gfs:size-width size)
              gfs::bottom (gfs:size-height size))
        (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer)))
      (warn 'gfs:toolkit-warning :detail "null surface size"))))

(defmethod gfs:dispose ((self graphics-context))
  (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+))
  (gfs::delete-object (pen-handle-of self))
  (setf (pen-handle-of self) nil)
  (let ((fn (dc-destructor-of self)))
    (unless (null fn)
      (if (null (widget-handle-of self))
        (funcall fn (gfs:handle self))
        (funcall fn (widget-handle-of self) (gfs:handle self)))))
  (setf (surface-size-of self) nil)
  (setf (widget-handle-of self) nil)
  (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))

(defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-bezier ((self graphics-context) start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-points-function #'gfs::poly-bezier
                        "poly-bezier"
                        (gfs:handle self)
                        (list start-pnt ctrl-pnt-1 ctrl-pnt-2 end-pnt)))

(defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt)))

(defmethod draw-ellipse ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)))

(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-filled-ellipse ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))

(defmethod draw-filled-pie-wedge ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))

(defmethod draw-filled-polygon ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 3)
    (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))

(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
  (if (gfs:disposed-p self)
      (error 'gfs:disposed-error))
   ( clim - gf::debug - prin1 " draw - filled - rect " self rect ) 
  (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))

(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))

(defmethod draw-image ((self graphics-context) (im image) (pnt gfs:point))
   ( clim - gf::debug - prin1 " draw - image " self i m ) 
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (if (gfs:disposed-p im)
    (error 'gfs:disposed-error))
  (let ((gc-dc (gfs:handle self))
        (himage (gfs:handle im))
        (tr-mask nil)
        (memdc (gfs::create-compatible-dc (cffi:null-pointer))))
    (cffi:with-foreign-object (bmp-ptr '(:struct gfs::bitmap))
      (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr (:struct gfs::bitmap))
        (gfs::get-object himage (cffi:foreign-type-size '(:struct gfs::bitmap)) bmp-ptr)
        (if (transparency-pixel-of im)
          (progn
            (setf tr-mask (transparency-mask im))
            (let ((hmask (gfs:handle tr-mask))
                  (hcopy (clone-bitmap himage))
                  (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))
                  (black (make-color :red 0 :green 0 :blue 0))
                  (white (make-color :red #xFF :green #xFF :blue #xFF)))
              (gfs::select-object memdc hmask)
              (gfs::select-object memdc2 hcopy)
              (gfs::set-bk-color memdc2 (color->rgb black))
              (gfs::set-text-color memdc2 (color->rgb white))
              (gfs::bit-blt memdc2
                            0 0
                            gfs::width
                            gfs::height
                            memdc
                            0 0 gfs::+blt-srcand+)
              (gfs::bit-blt gc-dc
                            (gfs:point-x pnt)
                            (gfs:point-y pnt)
                            gfs::width
                            gfs::height
                            memdc
                            0 0 gfs::+blt-srcand+)
              (gfs::bit-blt gc-dc
                            (gfs:point-x pnt)
                            (gfs:point-y pnt)
                            gfs::width
                            gfs::height
                            memdc2
                            0 0 gfs::+blt-srcpaint+)
              (gfs::delete-dc memdc2)
              (gfs::delete-object hcopy))
            (gfs:dispose tr-mask))
          (progn
            (gfs::select-object memdc himage)
            (gfs::bit-blt gc-dc
                          (gfs:point-x pnt)
                          (gfs:point-y pnt)
                          gfs::width
                          gfs::height
                          memdc
                          0 0 gfs::+blt-srccopy+)))))
    (gfs::delete-dc memdc)))

(defmethod draw-line ((self graphics-context) start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt)))

(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt)))

(defmethod draw-point ((self graphics-context) pnt)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (gfs::set-pixel (gfs:handle self)
                  (gfs:point-x pnt)
                  (gfs:point-y pnt)
                  (color->rgb (foreground-color self))))

(defmethod draw-poly-bezier ((self graphics-context) start-pnt points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (null points)
    (let ((tmp (loop for triplet in points
                     append (list (second triplet) (third triplet) (first triplet)))))
      (push start-pnt tmp)
      (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp))))

(defmethod draw-polygon ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 3)
    (with-null-brush (self)
      (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points))))

(defmethod draw-polyline ((self graphics-context) points)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (unless (< (length points) 2)
    (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points)))

(defmethod draw-rectangle ((self graphics-context) rect)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)))

(defmethod draw-rounded-rectangle ((self graphics-context) rect size)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (with-null-brush (self)
    (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size)))

(defmethod draw-text ((self graphics-context) text (pnt gfs:point) &optional style tab-width)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((flags (compute-draw-text-style style))
        (tb-width (if (null tab-width) 0 tab-width))
        (old-bk-mode (gfs::get-bk-mode (gfs:handle self))))
    (if (find :transparent style)
      (gfs::set-bk-mode (gfs:handle self) gfs::+transparent+))
    (cffi:with-foreign-object (dt-ptr '(:struct gfs::drawtextparams))
      (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin)
                                dt-ptr (:struct gfs::drawtextparams))
        (setf gfs::cbsize (cffi:foreign-type-size '(:struct gfs::drawtextparams)))
        (setf gfs::tablength tb-width)
        (setf gfs::leftmargin 0)
        (setf gfs::rightmargin 0)
        (gfs::with-rect (rect-ptr)
          (setf gfs::left (gfs:point-x pnt))
          (setf gfs::top (gfs:point-y pnt))
          (gfs::draw-text-ex (gfs:handle self)
                             text
                             -1
                             rect-ptr
                             (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+)))
                             dt-ptr)
          (gfs::draw-text-ex (gfs:handle self)
                             text
                             (length text)
                             rect-ptr
                             flags
                             dt-ptr)
          (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))

(defmethod (setf font) ((font font) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (gfs::select-object (gfs:handle self) (gfs:handle font)))

(defmethod foreground-color ((self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (rgb->color (gfs::get-text-color (gfs:handle self))))

(defmethod (setf foreground-color) ((clr color) (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (let ((rgb (color->rgb clr)))
    (gfs::set-text-color (gfs:handle self) rgb)
    (setf (logbrush-color-of self) rgb)
    (update-pen-for-gc self)))

(defmethod initialize-instance :after ((self graphics-context) &key image widget &allow-other-keys)
  (when (null (gfs:handle self))
    (let ((hdc (cffi:null-pointer)))
      (if (null widget)
        (progn
          (setf hdc (gfs::create-compatible-dc (cffi:null-pointer)))
          (setf (dc-destructor-of self) #'gfs::delete-dc))
        (progn
          (setf hdc (gfs::get-dc (gfs:handle widget)))
          (setf (dc-destructor-of self) #'gfs::release-dc)
          (setf (widget-handle-of self) (gfs:handle widget))
          (setf (surface-size-of self) (gfw:client-size widget))))
      (setf (slot-value self 'gfs:handle) hdc)
      (unless (null image)
        (setf (surface-size-of self) (gfg:size image))
        (gfs::select-object hdc (gfs:handle image)))))
  (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+)
  (update-pen-for-gc self))

(defmethod metrics ((self graphics-context) (font font))
  (if (or (gfs:disposed-p self) (gfs:disposed-p font))
    (error 'gfs:disposed-error))
  (let ((hdc (gfs:handle self))
        (hfont (gfs:handle font))
        (metrics nil))
    (gfs::with-hfont-selected (hdc hfont)
      (cffi:with-foreign-object (tm-ptr '(:struct gfs::textmetrics))
        (cffi:with-foreign-slots ((gfs::tmascent gfs::tmdescent gfs::tmexternalleading
                                   gfs::tmavgcharwidth gfs::tmmaxcharwidth)
                                  tm-ptr (:struct gfs::textmetrics))
          (if (zerop (gfs::get-text-metrics hdc tm-ptr))
            (error 'gfs:win32-error :detail "get-text-metrics failed"))
          (setf metrics (make-font-metrics :ascent gfs::tmascent
                                           :descent gfs::tmdescent
                                           :leading gfs::tmexternalleading
                                           :avg-char-width gfs::tmavgcharwidth
                                           :max-char-width gfs::tmmaxcharwidth)))))
    metrics))

(defmethod (setf pen-style) :around (style (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (slot-value self 'pen-style) style)
  (update-pen-for-gc self))

(defmethod (setf pen-width) :around (width (self graphics-context))
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (setf (slot-value self 'pen-width) width)
  (update-pen-for-gc self))

(defmethod text-extent ((self graphics-context) str &optional style tab-width)
  (if (gfs:disposed-p self)
    (error 'gfs:disposed-error))
  (text-bounds (gfs:handle self)
               str
               (compute-draw-text-style style)
               (if (or (null tab-width) (< tab-width 0)) 0 tab-width)))

(defun create-rect-region (vec)
  (apply 'gfs::create-rect-rgn (coerce vec 'list)))

(defmethod set-clipping-region ((self graphics-context) (clipping-region vector))
  (if (zerop (length clipping-region))
      (let ((rgn (create-rect-region #(0 0 0 0))))
	(gfs::select-clip-rgn (gfs:handle self) rgn)
	(gfs::delete-object rgn))
      (let ((rgn (create-rect-region clipping-region)))
	(gfs::select-clip-rgn (gfs:handle self) rgn)
	(gfs::delete-object rgn))))

(defmethod set-clipping-region ((self graphics-context) (clipping-region list))
  (assert clipping-region)
  (let ((rgn (create-rect-region (first clipping-region))))
    (gfs::select-clip-rgn (gfs:handle self) rgn)
    (gfs::delete-object rgn)
    (loop for tmp in (cdr clipping-region)
       for rgn = (create-rect-region tmp)
       do (progn
	    (gfs::ext-select-clip-rgn (gfs:handle self) rgn gfs::+rgn-or+)
	    (gfs::delete-object rgn)))))

(defmethod set-mix-mode ((self graphics-context) mix-mode)
  (gfs::set-rop2 (gfs:handle self) mix-mode))
