diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp new file mode 100644 index 0000000000000000000000000000000000000000..bd312f071d956dce8592a65e4f2ce023544cb922 --- /dev/null +++ b/clim/gadget-output.lisp @@ -0,0 +1,219 @@ +;; -*- mode: common-lisp; package: clim -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + +(in-package :clim) + + +;;; Implementation of output-records that are tied to gadgets. + +(defclass gadget-output-record (displayed-output-record) + ((gadget :initform nil + :accessor output-record-gadget))) + +(defmethod associate-record-and-gadget (rec gadget stream x y) + ;; Just in case + (setf (sheet-enabled-p gadget) nil) + (adopt-child stream gadget) + ;; In order to be able to determine the space the widget has to be + ;; added to the parent and hopefully grafted + (assert (port stream)) + (setf (output-record-gadget rec) gadget) + (let ((sr (compose-space gadget))) + (bounding-rectangle-set-edges + rec + x + y + (+ x (space-req-width sr)) + (+ y (space-req-height sr)))) + (when (output-record-stream rec) + (setf (sheet-enabled-p gadget) t))) + +(defmethod bounding-rectangle-set-edges :after ((rec gadget-output-record) + minx miny maxx maxy) + (when (output-record-gadget rec) + (silica::move-and-resize-sheet* + (output-record-gadget rec) + minx miny (- maxx minx) (- maxy miny)))) + +;; cover wagon fullsome - 7th . 9.30. cw saloon +;; Need to add the gadget to the stream + +(defmethod bounding-rectangle-set-position* :after + ((r gadget-output-record) new-x new-y) + (when (output-record-gadget r) + (silica::move-sheet* (output-record-gadget r) new-x new-y))) + +;; One problem we have is that when we scroll we will end up with +;; geometry requests being refused. +;; We want to enable/disable panes as they become (in)visible + + +(defmethod window-clear :after ((window extended-stream-sheet)) + (dolist (child (sheet-children window)) + (silica::disown-child window child))) + + +(defmacro with-output-as-gadget ((&rest args &key stream + &allow-other-keys) + &body body) + (default-output-stream stream) + (let ((fm (gensym)) + (f (gensym))) + (with-rem-keywords (args args '(:stream)) + `(with-output-as-gadget-internal + ,stream + #'(lambda (,fm ,f) + (with-look-and-feel-realization (,fm ,f) ,@body)) + ,@args)))) + +(defmethod with-output-as-gadget-internal (stream continuation &key) + (let* ((frame (silica::pane-frame stream)) + (framem (frame-manager frame))) + (assert frame) + (assert framem) + (multiple-value-bind + (x y) + (stream-cursor-position* stream) + (let* (gadget + (rec + (with-new-output-record (stream + 'gadget-output-record + rec) + (unless (setq gadget (output-record-gadget rec)) + (associate-record-and-gadget + rec + (setq gadget (funcall continuation framem frame)) + stream x y))))) + (move-cursor-beyond-output-record stream rec) + (values gadget rec))))) + + + +(define-presentation-method accept-present-default ((type boolean) + stream + (view gadget-dialog-view) + default default-supplied-p + present-p query-identifier) + (declare (ignore default-supplied-p present-p)) + (with-output-as-gadget (:stream stream) + (realize-pane 'silica::toggle-button + :client stream + :id query-identifier + :set default))) + + +(defmethod display-exit-boxes ((frame accept-values) stream) + ;; Do the fresh-line *outside* of the updating-output so that it + ;; doesn't get repositioned relatively in the X direction if the + ;; previous line gets longer. Maybe there should be some better + ;; way of ensuring this. + (fresh-line stream) + (with-slots (exit-boxes) frame + (let ((exit (or (second (assoc :exit exit-boxes)) "<End> uses these values")) + (abort (or (second (assoc :abort exit-boxes)) "<Abort> aborts"))) + (updating-output (stream :unique-id stream + :cache-value 'exit-boxes) + (with-output-as-gadget (:stream stream) + (assert frame) + (realize-pane 'silica::push-button + :client frame + :id :abort + :label abort)) + (with-output-as-gadget (:stream stream) + (realize-pane 'silica::push-button + :client frame + :id :exit + :label exit)))))) + +(defmethod silica::pane-frame ((stream encapsulating-stream-mixin)) + (silica::pane-frame (slot-value stream 'stream))) + +(defmethod graft ((stream encapsulating-stream-mixin)) + (graft (slot-value stream 'stream))) + +(defmethod adopt-child ((stream encapsulating-stream-mixin) child) + (adopt-child (slot-value stream 'stream) child)) + +(defmethod silica::activate-callback ((pb silica::push-button) + (client accept-values) + id) + (ecase id + (:abort (com-abort-avv)) + (:exit (com-exit-avv)))) + + +(define-command (com-change-query :command-table accept-values-pane) + ((id t) + (new-value t)) + (with-slots (value changed-p) id + (setf value new-value changed-p t))) + + +(defmethod silica::value-changed-callback ((gadget value-gadget) + (client avv-stream) + id + new-value) + (throw-highlighted-presentation + (make-instance 'standard-presentation + :object `(com-change-query ,id ,new-value) + :type 'command) + *input-context* + (make-instance 'silica::pointer-event + :sheet (slot-value client 'stream) + :x 0 + :y 0 + :modifiers 0 + :button 256))) + +;; incf redisplay wanted this! + +(defmethod clear-output-record ((rec gadget-output-record)) + nil) + +;; kludge because of clear-output-record :after +;; Perhaps this should be moved somewhere. +;; If think is because the clear-output-record stuff should be on +;; composite-output-records rather than displayed output-records + +(defmethod bounding-rectangle-set-edges :around ((rec gadget-output-record) + minx miny maxx maxy) + (unless (= minx miny maxx maxy) + (call-next-method))) + +#+ignore +(defmethod add-output-record :after ((child gadget-output-record) (parent t)) + (do ((p parent (output-record-parent p))) + ((null p) + (warn "Parent is not a output-history")) + (when (typep p 'stream-output-history-mixin) + (return t))) + ;; Perhaps we should enable the gadget at this point + nil) + +(defmethod note-output-record-attached ((rec gadget-output-record) stream) + (declare (ignore stream)) + (setf (sheet-enabled-p (output-record-gadget rec)) t)) + +(defmethod note-output-record-detached ((rec gadget-output-record)) + (setf (sheet-enabled-p (output-record-gadget rec)) nil)) diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp new file mode 100644 index 0000000000000000000000000000000000000000..61d5cddf1324d47598ee4de2b1bf1bf34d1ed024 --- /dev/null +++ b/tk/xm-font-list.lisp @@ -0,0 +1,89 @@ +;; -*- mode: common-lisp; package: tk -*- +;; +;; -[]- +;; +;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. +;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in FAR +;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as +;; applicable. +;; +;; $fiHeader$ + +(in-package :tk) + +(defforeign 'xm_font_list_init_font_context + :entry-point "_XmFontListInitFontContext") + +(defforeign 'xm_font_list_free_font_context + :entry-point "_XmFontListFreeFontContext") + + +(defforeign 'xm_font_list_get_next_font + :entry-point "_XmFontListGetNextFont") + +(defforeign 'xm_font_list_create + :entry-point "_XmFontListCreate") + + + +(defmethod convert-resource-out (parent (type (eql 'font-list)) value) + (declare (ignore parent)) + (when (atom value) + (setq value (list value))) + (let* ((charset xm_string_default_char_set) + (font-list + (xm_font_list_create + (object-handle (car value))))) + (dolist (font (cdr value)) + (setq font-list + (xm_font_list_add font-list + (object-handle font) + charset))) + font-list)) + +(defmethod convert-resource-in (class (type (eql 'font-list)) value) + (import-font-list value)) + +(defun import-font-list (font-list) + (let ((context + (with-ref-par ((context 0)) + (assert (not (zerop (xm_font_list_init_font_context context font-list)))) + (aref context 0))) + (res nil)) + (with-ref-par + ((char-set 0) + (font 0)) + (loop + (when (zerop + (xm_font_list_get_next_font + context + char-set + font)) + (return nil)) + (push (list (let ((x (aref char-set 0))) + (prog1 + (ff:char*-to-string x) + (xt_free x))) + (let ((x (aref font 0))) + (intern-object-address + x + 'font + :name :unknown!))) + res)) + (xm_font_list_free_font_context context) + res))) + +