Skip to content
Snippets Groups Projects
Commit 8be08531 authored by cer's avatar cer
Browse files

Initial revision

parent 249e9204
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
(in-package :clx-clim)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
;;; $fiHeader$
(defclass clx-frame-manager (standard-frame-manager)
())
(defmethod make-frame-manager ((port clx-port))
(make-instance 'clx-frame-manager :port port))
(defmethod adopt-frame :after ((framem clx-frame-manager)
(frame standard-application-frame))
(when (frame-panes frame)
(establish-wm-protocol-callbacks framem frame)))
(defmethod establish-wm-protocol-callbacks ((framem clx-frame-manager) frame)
(let ((shell (frame-shell frame)))
(tk::set-values shell
:icon-name (frame-pretty-name frame)
:title (frame-pretty-name frame)
:delete-response :do-nothing)
(tk::add-wm-protocol-callback
shell
:wm-delete-window
'frame-wm-protocol-callback
frame)))
;;; Definitions of the individual classes
;; This looks like garbage??
;(defclass motif-main-window (motif-composite-pane)
; (
; (contents :accessor main-window-contents :initform nil)
; (command-window :initform nil :accessor main-window-command-window)
; command-window-location
; menu-bar
; message-window
; ))
;
;(defmethod initialize-instance :after ((mw motif-main-window)
; &key
; command-window
; command-window-location
; menu-bar
; message-window
; contents)
; (when contents
; (setf (main-window-contents mw) contents))
; (when command-window
; (setf (main-window-command-window mw) command-window))
; (when message-window
; (setf (main-window-message-window mw) message-window)))
;
;(defmethod (setf main-window-contents) :after (nv (mw motif-main-window))
; (unless (sheet-parent nv)
; (sheet-adopt-child mw nv)))
;
;(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window))
; (unless (sheet-parent nv)
; (sheet-adopt-child mw nv)))
;
;#+ignore
;(defmethod realize-mirror :around (port (motif-main-window))
; (let ((m (call-next-method)))
; (tk::xm_set_main_window_areas
; (object-handle m)
; ..
; (and command-window (realize-mirror port command-window))
; ..
; (and message-window (realize-mirror port message-window))
; ...)))
;;;; Drawing area
;
;#+ignore
;(defclass motif-drawing-area (motif-composite-pane) ())
;
;;;; Row colum
;
;(defclass motif-row-colum (motif-composite-pane) ())
;
;;;; Push button
;#+ignore
;(defclass motif-push-button (motif-leaf-pane) ())
;;; Menu bar
;(defclass motif-menu-bar (motif-composite-pane) ())
;(defclass motif-pulldown-menu (motif-composite-pane) ())
;
;(defclass motif-cascade-button (motif-composite-pane)
; ((submenu :accessor cascade-button-submenu :initform nil))
; )
;
;(defmethod realize-mirror :around ((port clx-port) (sheet motif-cascade-button))
; (let ((m (call-next-method)))
; (when (cascade-button-submenu sheet)
; (tk::set-values m :sub-menu-id
; (realize-mirror port (cascade-button-submenu sheet))))
; m))
(defun frame-wm-protocol-callback (widget frame)
;; Invoked when the Wm close function has been selected
;; We want to queue an "event" somewhere so that we can
;; synchronously quit from the frame
(distribute-event
(sheet-port frame)
(make-instance 'window-manager-delete-event
:sheet (frame-top-level-sheet frame))))
(defmethod frame-wrapper ((framem clx-frame-manager)
(frame standard-application-frame) pane)
(with-look-and-feel-realization (framem frame)
(vertically ()
(realize-pane 'menu-bar
:command-table (frame-command-table frame))
pane)))
(defclass motif-menu-bar (xt-leaf-pane)
((command-table :initarg :command-table)))
(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-menu-bar))
(values 'tk::xm-menu-bar nil))
(defmethod realize-mirror :around ((port clx-port) (sheet motif-menu-bar))
;; This code fills the menu-bar. If top level items do not have
;; submenus then it creates one with a menu of its own
(let ((mirror (call-next-method)))
(labels ((make-menu-for-command-table (command-table parent top)
(map-over-command-table-menu-items
#'(lambda (menu keystroke item)
(declare (ignore keystroke))
(let ((type (command-menu-item-type item)))
(case type
(:divider)
(:function
;;--- Do this sometime
)
(:menu
(let* ((submenu (make-instance
'tk::xm-pulldown-menu
:managed nil
:parent parent))
(cb (make-instance 'tk::xm-cascade-button
:parent parent
:label-string menu
:sub-menu-id submenu)))
(declare (ignore cb))
(make-menu-for-command-table
(find-command-table (second item))
submenu
nil)))
(t
(let ((parent parent))
(when top
(let* ((submenu (make-instance
'tk::xm-pulldown-menu
:managed nil
:parent parent))
(cb (make-instance 'tk::xm-cascade-button
:parent parent
:label-string menu
:sub-menu-id
submenu)))
(declare (ignore cb))
(setq parent submenu)))
(let ((button
(make-instance 'tk::xm-push-button
:label-string menu
:managed t
:parent parent)))
(tk::add-callback
button
:activate-callback
'command-button-callback
(slot-value sheet 'silica::frame)
item)))))))
command-table)))
(make-menu-for-command-table
(slot-value sheet 'command-table)
mirror
t))
mirror))
(defclass presentation-event (event)
((value :initarg :value :reader presentation-event-value)
(sheet :initarg :sheet :reader event-sheet)))
(defmethod handle-event (sheet (event presentation-event))
(throw-highlighted-presentation
(make-instance 'standard-presentation
:object (presentation-event-value event)
:type 'command)
*input-context*
(make-instance 'pointer-button-press-event
:sheet sheet
:x 0
:y 0
:modifiers 0
:button 256)))
(defun command-button-callback (button dunno frame item)
(distribute-event
(sheet-port frame)
(make-instance 'presentation-event
:sheet (frame-top-level-sheet frame)
:value (second item))))
(defmethod port-dialog-view ((port clx-port))
+gadget-dialog-view+)
;;--- Should "ungray" the command button, if there is one
(defmethod note-command-enabled ((framem clx-frame-manager) frame command)
(declare (ignore frame command)))
;;--- Should "gray" the command button, if there is one
(defmethod note-command-disabled ((framem clx-frame-manager) frame command)
(declare (ignore frame command)))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
(in-package :clx-clim)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
;;; $fiHeader$
(defclass ask-widget-for-size-mixin () ())
(defmethod realize-pane-1 ((framem clx-frame-manager)
frame abstract-type &rest options)
(let ((type (apply #'realize-pane-class framem abstract-type options)))
(if type
(apply #'make-instance type
:frame frame
:frame-manager framem
(apply #'realize-pane-arglist
framem abstract-type options))
(call-next-method))))
(defmethod compose-space ((pane ask-widget-for-size-mixin))
(multiple-value-bind
(x y width height borderwidth
care-x care-y care-width care-height care-borderwidth)
(tk::widget-best-geometry (sheet-direct-mirror pane))
(declare (ignore x y borderwidth care-x care-y care-width
care-height care-borderwidth))
(make-instance 'silica::space-requirement :width width :height height)))
(defmethod realize-pane-arglist (realizer type &rest options)
(declare (ignore realizer type))
options)
;; Background/foreground/text-style mixin
(defmethod find-widget-class-and-initargs-for-sheet
:around
((port xt-port)
(sheet
silica::foreground-background-and-text-style-mixin))
(multiple-value-bind
(class initargs)
(call-next-method)
(with-slots
(silica::foreground silica::background text-style)
sheet
;; Background can either be a pixel of a bitmap
;; Foreground has to be a pixel
;; clx-decode-gadget-background
;; clx-decode-gadget-foreground
(when silica::background
(with-sheet-medium (medium sheet)
(setf initargs
(append (clx-decode-gadget-background medium sheet silica::background)
initargs))))
(when silica::foreground
(with-sheet-medium (medium sheet)
(setf initargs
(append (clx-decode-gadget-foreground medium sheet silica::foreground)
initargs))))
(when text-style
(setf (getf initargs :font-list)
(text-style-mapping port text-style)))
(values class initargs))))
(defmethod clx-decode-gadget-background (medium sheet ink)
(declare (ignore sheet))
(let ((gc (clx-decode-ink ink medium)))
(if (tk::gcontext-tile gc)
(list :background-pixmap (tk::gcontext-tile gc))
(list :background (tk::gcontext-foreground gc)))))
(defmethod clx-decode-gadget-foreground (medium sheet ink)
(declare (ignore sheet))
(let ((gc (clx-decode-ink ink medium)))
(if (tk::gcontext-tile gc)
(error "Gadget foreground cannot be pixmap")
(list :foreground (tk::gcontext-foreground gc)))))
(defclass xt-pane (silica::pane) ())
(defmethod allocate-space ((p xt-pane) width height)
(when (sheet-mirror p)
(tk::set-values (sheet-mirror p)
:width (floor width)
:height (floor height))))
;(defclass xt-composite-pane () ())
(defclass xt-leaf-pane (sheet-permanently-enabled-mixin
silica::client-overridability
xt-pane
mirrored-sheet-mixin
ask-widget-for-size-mixin)
())
(defmethod sheet-shell (sheet)
(do ((w (sheet-mirror sheet) (tk::widget-parent w)))
((typep w '(or tk::shell null))
w)))
(defmethod realize-pane-class ((framem clx-frame-manager) class &rest options)
(declare (ignore options))
(second (assoc class '(
(scroll-bar motif-scrollbar)
(slider motif-slider)
(push-button motif-push-button)
(canvas motif-drawing-area)
(text-field motif-text-field)
(toggle-button motif-toggle-button)
(menu-bar motif-menu-bar)
(viewport clx-viewport)
(radio-box motif-radio-box)
(frame-pane motif-frame-pane)
(silica::top-level-sheet motif-top-level-sheet)
;; One day
(line-editor-pane)
(label-button-pane)
(radio-button-pane)
(horizontal-divider-pane)
(vertical-divider-pane)
(label-pane)
;;
(list-pane)
(caption-pane)
(cascade-button)
))))
;;; We now need a lot of classes that mirror the xm classes.
;;; Motif widgets that support the :value resource and value-changed callback
(defclass motif-value-pane () ())
(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-value-pane) (widget t))
(tk::add-callback widget
:value-changed-callback
'queue-value-changed-event
sheet))
(defmethod gadget-value ((gadget motif-value-pane))
(if (sheet-direct-mirror gadget)
(tk::get-values (sheet-mirror gadget) :value)
(call-next-method)))
(defmethod (setf gadget-value) (nv (gadget motif-value-pane))
(when (sheet-mirror gadget)
(tk::set-values (sheet-mirror gadget) :value nv)))
(defmethod queue-value-changed-event (widget sheet)
(declare (ignore widget))
(distribute-event
(sheet-port sheet)
(make-instance 'value-changed-gadget-event
:gadget sheet
:value (gadget-value sheet))))
;;; Motif widgets that support the activate callback
(defclass motif-action-pane () ())
(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-action-pane) (widget t))
(tk::add-callback widget
:activate-callback
'queue-active-event
sheet))
(defmethod queue-active-event (widget count sheet)
(declare (ignore widget count))
(distribute-event
(sheet-port sheet)
(make-instance 'activate-gadget-event
:gadget sheet)))
;;; Push button
(defclass motif-push-button (xt-leaf-pane
push-button
motif-action-pane)
())
(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button))
(declare (ignore port))
(with-accessors ((label silica::gadget-label)) sheet
(values 'tk::xm-push-button
(list :label-string label))))
(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area))
(tk::add-callback widget
:expose-callback
'sheet-mirror-exposed-callback
sheet)
(tk::add-callback widget
:input-callback
'sheet-mirror-input-callback
sheet)
(tk::add-event-handler widget
'(:enter-window
:leave-window
:pointer-motion-hint
:pointer-motion
:button1-motion
:button2-motion
:button3-motion
:button4-motion
:button5-motion
:button-motion
)
0
'sheet-mirror-event-handler
sheet))
;; Drawing area
;; Who uses this anyway??????????????
(defclass motif-drawing-area (xt-leaf-pane
standard-sheet-input-mixin
permanent-medium-sheet-output-mixin
mute-repainting-mixin)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-drawing-area))
(values 'tk::xm-drawing-area (list :margin-width 0
:resize-policy :none
:margin-height 0)))
(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget)
;; Now does nothing
)
;;; Slider
(defclass motif-slider (xt-leaf-pane
motif-value-pane
slider)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet motif-slider))
(with-accessors ((orientation silica::gadget-orientation)
(label silica::gadget-label)
(value gadget-value)) sheet
(values 'tk::xm-scale
(append
(and label (list :title-string label))
(list :orientation orientation)
(and value (list :value value))))))
(defmethod compose-space ((m motif-slider))
(let ((x 16))
(ecase (silica::gadget-orientation m)
(:vertical
(make-space-requirement :width x
:min-height x
:height (* 2 x)
:max-height +fill+))
(:horizontal
(make-space-requirement :height (if (silica::gadget-label m) ;
;Should ask the label how big
;it wants to be and add that in
(+ x 20)
x)
:min-width x
:width (* 2 x)
:max-width +fill+)))))
;;; Scrollbar
(defclass motif-scrollbar (xt-leaf-pane
silica::scrollbar)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-scrollbar))
(with-accessors ((orientation silica::gadget-orientation)) sheet
(values 'tk::xm-scroll-bar
(list :orientation orientation))))
(defmethod (setf silica::scrollbar-size) (nv (sb motif-scrollbar))
(tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv))
nv)
(defmethod (setf silica::scrollbar-value) (nv (sb motif-scrollbar))
(tk::set-values (sheet-direct-mirror sb) :value nv)
nv)
(defmethod silica::change-scrollbar-values ((sb motif-scrollbar) &rest args
&key slider-size value)
(declare (ignore slider-size value))
(apply #'tk::set-values
(sheet-direct-mirror sb)
args))
(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scrollbar) (widget t))
(tk::add-callback widget
:value-changed-callback
'scrollbar-changed-callback-1
sheet))
(defun scrollbar-changed-callback-1 (widget sheet)
(multiple-value-bind
(value size)
(tk::get-values widget :value :slider-size)
(silica::scrollbar-value-changed-callback
sheet
(gadget-client sheet)
(gadget-id sheet)
value
size)))
(defmethod compose-space ((m motif-scrollbar))
(let ((x 16))
(ecase (silica::gadget-orientation m)
(:vertical
(make-space-requirement :width x
:min-height x
:height (* 2 x)
:max-height +fill+))
(:horizontal
(make-space-requirement :height x
:min-width x
:width (* 2 x)
:max-width +fill+)))))
;; Should we stick in our preferred scrollbar geometry here?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass clx-top-level-sheet (top-level-sheet) ())
;;;; text field
(defclass motif-text-field (xt-leaf-pane
motif-value-pane motif-action-pane
text-field)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-text-field))
(with-accessors ((value gadget-value)) sheet
(values 'tk::xm-text-field
(append
(and value `(:value ,value))))))
;;; Toggle button
(defclass motif-toggle-button (xt-leaf-pane
motif-value-pane
toggle-button)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-toggle-button))
(with-accessors ((set gadget-value)
(label silica::gadget-label)
(indicator-type silica::gadget-indicator-type)) sheet
(values 'tk::xm-toggle-button
(append (list :set set)
(and label (list :label-string label))
(list :indicator-type
(ecase indicator-type
(:one-of :one-of-many)
(:some-of :n-of-many)))))))
(defmethod gadget-value ((gadget motif-toggle-button))
(if (sheet-direct-mirror gadget)
(tk::get-values (sheet-mirror gadget) :set)
(call-next-method)))
(defmethod (setf gadget-value) (nv (gadget motif-toggle-button))
(when (sheet-direct-mirror gadget)
(tk::set-values (sheet-mirror gadget) :set nv)))
(defmethod xm-silica::add-sheet-callbacks :after ((port motif-port)
(sheet clim-stream-sheet)
(widget t))
(declare (ignore sheet))
; (tk::add-callback widget
; :expose-callback
; 'sheet-mirror-exposed-callback
; sheet)
; (tk::add-callback widget
; :input-callback
; 'sheet-mirror-input-callback
; sheet)
; (tk::add-event-handler widget
; '(:enter-window
; :leave-window
; :pointer-motion-hint
; :pointer-motion
; :button1-motion
; :button2-motion
; :button3-motion
; :button4-motion
; :button5-motion
; :button-motion
; )
; 0
; 'sheet-mirror-event-handler
; sheet)
;; It would suprise me if we needed this.
(tk::add-callback widget
:resize-callback
'sheet-mirror-resized-callback
sheet))
(defun scrollbar-changed-callback (widget which scroller)
(let* ((vp (silica::sheet-child scroller))
(viewport (viewport-viewport-region vp))
(extent (stream-output-history (sheet-child vp))))
(multiple-value-bind
(value size)
(tk::get-values widget :value :slider-size)
(case which
(:vertical
(scroll-extent
(sheet-child vp)
:x (bounding-rectangle-min-x viewport)
:y (truncate
(* (max 0 (- (bounding-rectangle-height extent)
(bounding-rectangle-height viewport)))
(if (= size 100)
0
(/ value (- 100 size)))))))
(:horizontal
(scroll-extent
(silica::sheet-child vp)
:x (truncate
(* (max 0 (- (bounding-rectangle-width extent)
(bounding-rectangle-width viewport)))
(if (= size 100)
0
(/ value (- 100 size)))))
:y (bounding-rectangle-min-y viewport)))))))
;;;;;;;;;;;;;;;
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet xm-viewport))
(values 'tk::xm-drawing-area
'(:scrolling-policy :application-defined
:margin-width 0 :margin-height 0
:resize-policy :none
:scroll-bar-display-policy :static)))
(defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-viewport) widget)
;; I wonder whether this is needed since it should not be resized by
;; the toolkit and only as part of the goe management code that will
;; recurse to children anyway
(tk::add-callback widget
:resize-callback
'sheet-mirror-resized-callback
sheet)
; (tk::add-callback widget
; :expose-callback
; 'sheet-mirror-exposed-callback
; sheet)
; (tk::add-callback widget
; :input-callback
; 'sheet-mirror-input-callback
; sheet)
; (tk::add-event-handler widget
; '(:enter-window
; :leave-window
; :pointer-motion-hint
; :pointer-motion
; :button1-motion
; :button2-motion
; :button3-motion
; :button4-motion
; :button5-motion
; :button-motion
; )
; 0
; 'sheet-mirror-event-handler
; sheet)
)
;; In some ways this behaves like a leaf since the management of the
;; children is left to the row column widget
(defclass motif-radio-box (mirrored-sheet-mixin
sheet-multiple-child-mixin
sheet-permanently-enabled-mixin
radio-box
silica::pane
ask-widget-for-size-mixin)
((current-selection :accessor radio-box-current-selection)))
(defmethod sheet-adopt-child :after ((gadget motif-radio-box) child)
(setf (gadget-client child) gadget))
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-radio-box))
(with-accessors ((orientation silica::gadget-orientation)) sheet
(values 'tk::xm-radio-box
(list :orientation orientation))))
(defmethod value-changed-callback :after ((v gadget)
(client motif-radio-box)
(id t)
(value t))
(when (eq value t)
(setf (radio-box-current-selection client) v)
(value-changed-callback client
(gadget-client client)
(gadget-id client)
v)))
;; This is an experiment at using a frame but there are problems with it
(defclass motif-frame-pane (mirrored-sheet-mixin
sheet-single-child-mixin
sheet-permanently-enabled-mixin
silica::pane
ask-widget-for-size-mixin)
())
(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
(sheet motif-frame-pane))
(values 'tk::xm-frame nil))
This diff is collapsed.
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
(in-package :clx-clim)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
(in-package :clx-clim)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
(defclass clx-port (port)
((application-shell :reader port-application-shell)
(display :reader port-display)
(context :reader port-context))
(:default-initargs :allow-loose-text-style-size-mapping t))
(defmethod find-port-type ((type (eql ':clx)))
'clx-port)
(defmethod initialize-instance :after ((port clx-port) &key server-path)
(destructuring-bind (ignore &key display) server-path
(declare (ignore ignore))
(multiple-value-bind (context display application-shell)
(initialize-motif-toolkit display)
(setf (slot-value port 'application-shell) application-shell
(slot-value port 'context) context
(slot-value port 'display) display)
(initialize-clx-port port display))))
;;; Text styles for CLX windows
(defvar *clx-font-families* '((:fix "*-courier-*")
(:sans-serif "*-helvetica-*")
(:serif "*-charter-*" "*-new century schoolbook-*" "*-times-*")))
(defun disassemble-x-font-name (name)
(let ((cpos 0)
(tokens nil))
(loop
(let ((dpos (position #\- name :start cpos)))
(when (null dpos)
(push (subseq name cpos) tokens)
(return))
(push (if (= cpos dpos)
nil
(subseq name cpos dpos))
tokens)
(setf cpos (1+ dpos))))
(reverse tokens)))
(defvar *clx-fallback-font* "8x13"
"When non NIL and nothing better exists use this as the fallback font")
(defmethod initialize-instance :after ((port clx-port)
&key display screen)
(let* ((screen-height (xlib:screen-height screen))
;; Use a float value so formula below will be accurate.
(screen-pixels-per-inch
(* 25.4 (/ screen-height
(xlib:screen-height-in-millimeters screen)))))
(flet ((font->text-style (font family)
(let* ((tokens (disassemble-x-font-name font))
(italic (member (fifth tokens) '("i" "o") :test #'equalp))
(bold (equalp (fourth tokens) "Bold"))
(face (if italic
(if bold '(:bold :italic) :italic)
(if bold :bold :roman)))
(designed-point-size (parse-integer (ninth tokens)))
(designed-y-resolution (parse-integer (nth 10 tokens)))
(point-size (* (float designed-point-size)
(/ designed-y-resolution
screen-pixels-per-inch)))
(size (/ point-size 10)))
(make-text-style family face size))))
(dolist (family-stuff *clx-font-families*)
(let ((family (car family-stuff)))
(dolist (font-pattern (cdr family-stuff))
(dolist (xfont (xlib:list-font-names display font-pattern))
(let ((text-style (font->text-style xfont family)))
;; prefer first font satisfying this text style, so
;; don't override if we've already defined one.
(unless (text-style-mapping-exists-p
port text-style *standard-character-set* t)
(setf (text-style-mapping port text-style) xfont)))))
;; Now build the logical size alist for the family
))))
(setq *cursor-font* (xlib:open-font display "cursor"))
;; We now need to find to establish the
;; *undefined-text-style* -> some abstract font mapping -> some real font
;; doing something horrible if that fails.
(let (temp)
(cond ((setq temp
(dolist (family *clx-font-families*)
(when (text-style-mapping-exists-p
port `(,(car family) :roman 10))
(return (make-text-style (car family) :roman 10)))))
(setf (text-style-mapping
port (port-undefined-text-style port))
temp))
;; Perhaps we should look for some other conveniently sized
;; fonts.
(*clx-fallback-font*
(setf (text-style-mapping
port (port-undefined-text-style port))
(xlib:open-font display
*clx-fallback-font*)))
;; Perhaps we should just grab the first font we can find.
(t
(error "Unable to determine default font")))))
(defparameter *clx-logical-size-alist*
'((:tiny 6)
(:very-small 8)
(:small 10)
(:normal 12)
(:large 14)
(:very-large 18)
(:huge 24)))
(defmethod standardize-text-style ((port clx-port) style
&optional (character-set *standard-character-set*))
(standardize-text-style-1
port style character-set *clx-logical-size-alist*))
(defmethod silica::destroy-mirror ((port clx-port) sheet)
(tk::destroy-widget (sheet-direct-mirror sheet)))
(defmethod realize-mirror ((port clx-port) sheet)
(multiple-value-bind (class initargs)
(find-widget-class-and-initargs-for-sheet port sheet)
(let ((widget (apply #'make-instance class
:parent (find-widget-parent port sheet)
:managed (sheet-enabled-p sheet)
initargs)))
(add-sheet-callbacks port sheet widget)
widget)))
(defmethod add-sheet-callbacks ((port clx-port) sheet (widget t))
(declare (ignore sheet)))
(defmethod sheet-mirror-event-handler (widget event sheet)
(multiple-value-bind
(same-p root child root-x root-y native-x native-y mask)
(tk::query-pointer (tk::widget-window widget))
(declare (ignore same-p root child root-x root-y))
(let ((modifiers (logand #16rff mask))
(button (ash mask -8)))
(distribute-event
(sheet-port sheet)
(ecase (tk::event-type event)
(:leave-notify
(make-instance 'pointer-exit-event
:native-x native-x
:native-y native-y
:button (x-button->silica-button button)
:modifiers modifiers
:sheet sheet))
(:enter-notify
(make-instance 'pointer-enter-event
:native-x native-x
:native-y native-y
:button (x-button->silica-button button)
:modifiers modifiers
:sheet sheet))
(:motion-notify
(make-instance 'pointer-motion-event
:native-x native-x
:native-y native-y
:button (x-button->silica-button button)
:modifiers modifiers
:sheet sheet)))))))
(defun x-button->silica-button (button)
(ecase button
(0 nil)
(4
(warn "got an event 4")
silica::+pointer-right-button+)
(#.x11::button3 +pointer-right-button+)
(#.x11::button2 +pointer-middle-button+)
(#.x11::button1 +pointer-left-button+)))
(defmethod sheet-mirror-resized-callback (widget window event sheet)
(declare (ignore widget window event))
(dispatch-event
sheet
(let ((r (mirror-region (sheet-port sheet) sheet)))
(make-instance 'window-configuration-event
:native-region r
:region (untransform-region
(sheet-native-transformation
sheet)
r)
:sheet sheet))))
(defmethod sheet-mirror-exposed-callback (widget window event sheet)
(declare (ignore widget window))
(let* ((minx (x11::xexposeevent-x event))
(miny (x11::xexposeevent-y event))
(width (x11::xexposeevent-width event))
(height (x11::xexposeevent-height event))
(maxx (+ minx width))
(maxy (+ miny height)))
(dispatch-repaint
sheet
(make-instance 'window-repaint-event
:native-region (make-bounding-rectangle minx miny maxx maxy)
:region (untransform-region
(sheet-native-transformation sheet)
(make-bounding-rectangle minx miny maxx maxy))
:sheet sheet))))
(defmethod sheet-mirror-input-callback (widget window event sheet)
(declare (ignore widget window))
(ecase (tk::event-type event)
(:key-press
(distribute-event
(sheet-port sheet)
(multiple-value-bind
(ignore character keysym)
(tk::lookup-string event)
(declare (ignore ignore))
(make-instance 'key-press-event
:key-name keysym
:character (and (= (length character) 1)
(aref character 0))
:sheet sheet
:modifiers (x11::xkeyevent-state event)))))
(:key-release
(distribute-event
(sheet-port sheet)
(multiple-value-bind
(ignore character keysym)
(tk::lookup-string event)
(declare (ignore ignore))
(make-instance 'key-release-event
:key-name keysym
:character (and (= (length character) 1)
(aref character 0))
:sheet sheet
:modifiers (x11::xkeyevent-state event)))))
(:button-press
(distribute-event
(sheet-port sheet)
(make-instance 'pointer-button-press-event
:sheet sheet
:x :??
:y :??
:modifiers (x11::xkeyevent-state event)
:button (x-button->silica-button
(x11::xbuttonevent-button event))
:native-x (x11::xbuttonevent-x event)
:native-y (x11::xbuttonevent-y event))))
(:button-release
(distribute-event
(sheet-port sheet)
(make-instance 'pointer-button-release-event
:sheet sheet
:x :??
:y :??
:modifiers (x11::xkeyevent-state event)
:button (x-button->silica-button
(x11::xbuttonevent-button event))
:native-x (x11::xbuttonevent-x event)
:native-y (x11::xbuttonevent-y event))))))
(defmethod find-widget-class-and-initargs-for-sheet
((port clx-port) (parent t) (sheet sheet))
(declare (ignore port))
(values 'xm-drawing-area (list :resize-policy :grow)))
(defmethod find-widget-class-and-initargs-for-sheet :around
((port clx-port) (parent t) (sheet sheet))
(declare (ignore port))
(multiple-value-bind
(class initargs)
(call-next-method)
(setq initargs (set-mirror-geometry sheet initargs))
(values class initargs)))
(defmethod set-mirror-geometry (sheet initargs)
(unless (getf initargs :x)
(multiple-value-bind (left top right bottom)
(sheet-actual-native-edges* sheet)
(setf (getf initargs :x) (floor left)
(getf initargs :y) (floor top)
(getf initargs :width) (floor (- right left))
(getf initargs :height) (floor (- bottom top)))))
initargs)
;; If we are creating a top level sheet then we have to create a shell
;; for it
(defmethod find-widget-parent ((port clx-port) sheet)
(let ((ma (sheet-mirrored-ancestor sheet)))
(if (graftp ma)
(multiple-value-bind
(class initargs)
(find-shell-class-and-initargs port sheet)
(apply #'make-instance class
:parent (port-application-shell port)
initargs))
(sheet-mirror ma))))
(defmethod find-shell-class-and-initargs ((port clx-port) sheet)
(values 'top-level-shell
;; Need this so that an interactive pane can have children
;; but still accept the focus
'(:keyboard-focus-policy :pointer)))
(defmethod enable-mirror ((port clx-port) sheet)
(declare (ignore port))
(let ((mirror (sheet-mirror sheet)))
(typecase (widget-parent mirror)
(null)
(top-level-shell
;; this is a nasty hack just to make sure that the child is managed.
;; top-level-sheets are created unmanaged because they are
;; disabled to we have to do not!
(manage-child mirror)
(popup (widget-parent mirror)))
(t
(manage-child mirror)))))
(defmethod disable-mirror ((port clx-port) sheet)
(declare (ignore port))
(let ((mirror (sheet-mirror sheet)))
(when mirror
(typecase (widget-parent mirror)
(null)
(top-level-shell
(tk::popdown (widget-parent mirror)))
(t
(tk::unmanage-child mirror))))))
(defmethod realize-graft ((port clx-port) graft)
;; Set the width etc etc
(setf (sheet-direct-mirror graft) (port-application-shell port))
;; Mess with the region
(warn "Do something about the graft")
(setf (sheet-region graft)
(make-bounding-rectangle 0 0 1100 850))
;; Mess with the native transformation
)
(defmethod mirror-region* ((port clx-port) sheet)
(when (sheet-mirror sheet)
(multiple-value-bind
(x y width height)
(get-values (sheet-mirror sheet) :x :y :width :height)
(values x y
(+ x width)
(+ y height)))))
(defmethod mirror-region ((port clx-port) sheet)
(multiple-value-call #'make-bounding-rectangle
(mirror-region* port sheet)))
(defmethod mirror-inside-region* ((port clx-port) sheet)
(multiple-value-bind
(minx miny maxx maxy)
(mirror-region* port sheet)
(values 0 0 (- maxx minx) (- maxy miny))))
(defmethod mirror-native-edges* ((port clx-port) sheet)
(let* ((mirror (sheet-direct-mirror sheet)))
(multiple-value-bind
(x y width height)
(get-values mirror :x :y :width :height)
(values x y (+ x width) (+ y height)))))
(defmethod mirror-inside-edges* ((port clx-port) sheet)
(multiple-value-bind (left top right bottom)
(mirror-native-edges* port sheet)
(values 0 0 (- right left) (- bottom top))))
(defmethod set-sheet-mirror-edges* ((port clx-port) sheet
target-left target-top
target-right target-bottom)
(let ((w (- target-right target-left))
(h (- target-bottom target-top)))
(tk::set-values (sheet-direct-mirror sheet)
:x (floor target-left)
:y (floor target-top)
:width (floor w)
:height (floor h))
(multiple-value-bind
(nx ny nw nh)
(tk::get-values (sheet-direct-mirror sheet)
:x :y :width :height)
(when (or (/= target-left nx)
(/= target-top ny)
(/= w nw)
(/= h nh))
(warn "Geo set fail, ~S, ~S,~S"
sheet
(list target-left target-top w h)
(list nx ny nw nh))))))
(defmethod process-next-event (port &key wait-function timeout)
(tk::process-one-event (port-context port)
:wait-function wait-function
:timeout timeout))
(defmethod port-force-output ((port clx-port))
nil)
(defmethod port-finish-output ((port clx-port))
nil)
(defmethod port-glyph-for-character ((port clx-port)
character style &optional our-font)
(let* ((index (char-int character))
(x-font (or our-font
(realize-text-style port appearance)))
(escapement-x (tk::char-width x-font index))
(escapement-y 0)
(origin-x 0)
(origin-y (tk::font-ascent x-font))
(bb-x escapement-x)
(bb-y (+ origin-y (tk::font-descent x-font))))
(when (zerop escapement-x) (break))
(values index x-font escapement-x escapement-y
origin-x origin-y bb-x bb-y)))
;; This seem specific to the type of the medium
(defmethod text-style-mapping :around ((port clx-port) text-style
&optional (character-set *standard-character-set*) etc)
(declare (ignore etc))
(let ((font (call-next-method)))
(when (or (stringp font) (symbolp font))
(let* ((font-name (string font)))
(with-slots (display) port
(setf font (xlib:open-font display font-name)))
(setf (text-style-mapping
port (parse-text-style text-style) character-set)
font)))
font))
(defmethod text-style-width ((text-style standard-text-style) (port clx-port))
(let ((font (text-style-mapping port text-style)))
;; Disgusting, but probably OK
(xlib:char-width font (xlib:char->card8 #\A))))
(defmethod text-style-height ((text-style standard-text-style) (port clx-port))
(let ((font (text-style-mapping port text-style)))
(let* ((ascent (xlib:font-ascent font))
(descent (xlib:font-descent font))
(height (+ ascent descent)))
height)))
(defmethod text-style-ascent ((text-style standard-text-style) (port clx-port))
(let ((font (text-style-mapping port text-style)))
(xlib:font-ascent font)))
(defmethod text-style-descent ((text-style standard-text-style) (port clx-port))
(let ((font (text-style-mapping port text-style)))
(xlib:font-descent font)))
(defmethod text-style-fixed-width-p ((text-style standard-text-style) (port clx-port))
(let ((font (text-style-mapping port text-style)))
;; Really disgusting, but probably OK
(= (xlib:char-width font (xlib:char->card8 #\.))
(xlib:char-width font (xlib:char->card8 #\M)))))
#+ignore
(ff::defforeign 'xtsetkeyboardfocus
:entry-point "_XtSetKeyboardFocus")
;;--- This is on the port and a sheet??
(defmethod stream-set-input-focus (stream)
nil)
;;--- This is on the port and a sheet??
(defmethod stream-restore-input-focus (stream)
nil)
(defmethod port-note-cursor-change ((port motif-port)
cursor stream type old new)
(declare (ignore old type cursor))
(call-next-method)
(when new
(xmprocesstraversal (tk::object-handle (sheet-mirror stream)) 0)
#+ignore
(xtsetkeyboardfocus #+ignroe(tk::object-handle (sheet-mirror (sheet-top-level-mirror stream)))
(tk::object-handle (sheet-mirror stream))
(tk::object-handle (sheet-mirror stream))))
(setf (port-keyboard-input-focus port)
(and new stream)))
This diff is collapsed.
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
;;; $fiHeader$
(#-ANSI-90 clim-lisp::defpackage #+ANSI-90 defpackage clx-clim
(:use clim-lisp clim-sys clim clim-utils silica))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment