[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
dlichteblau
dlichteblau at common-lisp.net
Wed Mar 14 23:42:41 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms
In directory clnet:/tmp/cvs-serv21895
Modified Files:
gadgets.lisp graft.lisp medium.lisp port.lisp
Log Message:
g-f fixes, including keyboard and mouse events.
* Backends/Graphic-Forms/gadgets.lisp (REALIZE-MIRROR): Spell
gfw-scroll-bar correctly, with a dash.
* Backends/Graphic-Forms/graft.lisp (graft-height): Fixed order of
arguments to gethash.
* Backends/Graphic-Forms/medium.lisp (sync-text-style): It's
:sans-serif, not :sansserif. Use ECASE to avoid this going
undetected. Allow family names that are strings, not symbols, and
pass them through unchanged.
* Backends/Graphic-Forms/port.lisp (resolve-abstract-pane-name):
Copy&paste from gtkairo. (make-pane-2): Call make-instance
with a real class name, not the pane type spec.
((realize-mirror mirrored-sheet-mixin)): Removed the :border
style. (port-frame-keyboard-input-focus, and its setf method):
New methods. (translate-button-name, char-to-sym): New functions.
(gfw:event-mouse-move, gfw:event-mouse-up, gfw:event-mouse-down,
gfw:event-key-up, gfw:event-key-down): New methods.
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2
@@ -141,7 +141,7 @@
(defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar))
(gfs::debug-format "realizing ~a~%" gadget)
(let* ((parent-mirror (sheet-mirror (sheet-parent gadget)))
- (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical)))
+ (mirror (make-instance 'gfw-scroll-bar :parent parent-mirror :style :vertical)))
(climi::port-register-mirror port gadget mirror)
mirror))
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:42:40 1.2
@@ -37,7 +37,7 @@
(defmethod graft-height ((graft graphic-forms-graft) &key (units :device))
(gfw:with-root-window (window)
- (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes))))
+ (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics)))))
(gfw:with-graphics-context (gc window)
(ecase units
(:device (gfs:size-height size))
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:42:40 1.2
@@ -92,10 +92,12 @@
;;
(gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))
(let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc)))
- (face-name (case family
- ((:fix :fixed) "Lucida Console")
- (:serif "Times New Roman")
- (:sansserif "Arial")))
+ (face-name (if (stringp family)
+ family
+ (ecase family
+ ((:fix :fixed) "Lucida Console")
+ (:serif "Times New Roman")
+ (:sans-serif "Arial"))))
(pnt-size (case size
(:tiny 6)
(:very-small 8)
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:42:40 1.2
@@ -122,10 +122,21 @@
(setf (get :graphic-forms :port-type) 'graphic-forms-port)
(setf (get :graphic-forms :server-path-parser) 'parse-graphic-forms-server-path)
+(defun resolve-abstract-pane-name (type)
+ (when (get type 'climi::concrete-pane-class-name)
+ (setf type (get type 'climi::concrete-pane-class-name)))
+ (class-name
+ (or (find-class
+ (intern (concatenate 'string (symbol-name type) "-PANE") :climi)
+ nil)
+ (if (keywordp type)
+ (find-class (intern (symbol-name type) :climi))
+ (find-class type)))))
+
(defgeneric make-pane-2 (type &rest initargs)
(:documentation "Implement this to instantiate specific pane types.")
(:method (type &rest initargs)
- (apply #'make-instance type initargs)))
+ (apply #'make-instance (resolve-abstract-pane-name type) initargs)))
;;;
;;; helper functions
@@ -211,7 +222,7 @@
(mirror (make-instance 'gfw-panel
:sheet sheet
:dispatcher *sheet-dispatcher*
- :style '(:border)
+ :style '() ;was: '(:border)
:parent parent)))
(setf (gfw:size mirror) (requirement->size req))
(multiple-value-bind (x y)
@@ -335,6 +346,16 @@
;;; Set the keyboard input focus for the port.
+(defmethod port-frame-keyboard-input-focus
+ ((port graphic-forms-port) frame)
+ ;; fixme
+ (frame-properties frame 'focus))
+
+(defmethod (setf port-frame-keyboard-input-focus)
+ (focus (port graphic-forms-port) frame)
+ (gfw:give-focus (sheet-mirror focus))
+ (setf (frame-properties frame 'focus) focus))
+
(defmethod %set-port-keyboard-focus (focus (port graphic-forms-port) &key timestamp)
(declare (ignore timestamp))
())
@@ -420,6 +441,109 @@
:sheet (sheet (gfw:owner mirror))
:item (sheet mirror))))
+(defun translate-button-name (name)
+ (case name
+ (:left-button +pointer-left-button+)
+ (:right-button +pointer-right-button+)
+ (:middle-button +pointer-middle-button+)
+ (t
+ (warn "unknown button name: ~A" name)
+ nil)))
+
+(defmethod gfw:event-mouse-move
+ ((self sheet-event-dispatcher) mirror point button)
+ (setf (event (port self))
+ (make-instance 'pointer-motion-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
+;;; :timestamp
+;;; :graft-x
+;;; :graft-y
+ :modifier-state 0
+ )))
+
+(defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button)
+ (setf (event (port self))
+ (make-instance 'pointer-button-press-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
+;;; :timestamp
+;;; :graft-x
+;;; :graft-y
+ :modifier-state 0
+ )))
+
+(defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button)
+ (setf (event (port self))
+ (make-instance 'pointer-button-release-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
+;;; :timestamp
+;;; :graft-x
+;;; :graft-y
+ :modifier-state 0
+ )))
+
+(defun char-to-sym (char)
+ (case char
+ (#\ :| |) (#\! :!) (#\" :|"|) (#\# :|#|) (#\$ :$) (#\% :%) (#\& :&)
+ (#\' :|'|) (#\( :|(|) (#\) :|)|) (#\* :*) (#\+ :+) (#\, :|,|) (#\- :-)
+ (#\. :|.|) (#\/ :/) (#\0 :|0|) (#\1 :|1|) (#\2 :|2|) (#\3 :|3|) (#\4 :|4|)
+ (#\5 :|5|) (#\6 :|6|) (#\7 :|7|) (#\8 :|8|) (#\9 :|9|) (#\: :|:|) (#\; :|;|)
+ (#\< :<) (#\= :=) (#\> :>) (#\? :?) (#\@ :@) (#\A :A) (#\B :B) (#\C :C)
+ (#\D :D) (#\E :E) (#\F :F) (#\G :G) (#\H :H) (#\I :I) (#\J :J) (#\K :K)
+ (#\L :L) (#\M :M) (#\N :N) (#\O :O) (#\P :P) (#\Q :Q) (#\R :R) (#\S :S)
+ (#\T :T) (#\U :U) (#\V :V) (#\W :W) (#\X :X) (#\Y :Y) (#\Z :Z) (#\[ :[)
+ (#\\ :|\\|) (#\] :]) (#\_ :_) (#\` :|`|) (#\a :|a|) (#\b :|b|) (#\c :|c|)
+ (#\d :|d|) (#\e :|e|) (#\f :|f|) (#\g :|g|) (#\h :|h|) (#\i :|i|) (#\j :|j|)
+ (#\k :|k|) (#\l :|l|) (#\m :|m|) (#\n :|n|) (#\o :|o|) (#\p :|p|) (#\q :|q|)
+ (#\r :|r|) (#\s :|s|) (#\t :|t|) (#\u :|u|) (#\v :|v|) (#\w :|w|) (#\x :|x|)
+ (#\y :|y|) (#\z :|z|) (#\{ :{) (#\| :|\||) (#\} :}) (#\Backspace :BACKSPACE)
+ (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE)))
+
+(defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char)
+ (setf (event (port self))
+ (make-instance 'key-press-event
+ :key-name (char-to-sym char)
+ :key-character char
+ :sheet (sheet mirror)
+ ;; FIXME:
+ :x 0
+ :y 0
+ :modifier-state 0
+;;; :timestamp time
+;;; :graft-x root-x
+;;; :graft-y root-y
+ )))
+
+(defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char)
+ (setf (event (port self))
+ (make-instance 'key-release-event
+ :key-name (char-to-sym char)
+ :key-character char
+ :sheet (sheet mirror)
+ ;; FIXME:
+ :x 0
+ :y 0
+ :modifier-state 0
+;;; :timestamp time
+;;; :graft-x root-x
+;;; :graft-y root-y
+ )))
+
+
;;;
;;; McCLIM handle-event methods
;;;
More information about the Mcclim-cvs
mailing list