src/gui/gui.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GUI; -*-
   2 ;;; --------------------------------------------------------------------------
   3 ;;;     Title: Toolkit independent GUI stuff (albeit X specific)
   4 ;;;   Created: Sun Jan 17 06:45:18 1999
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; --------------------------------------------------------------------------
   8 ;;;  (c) copyright 1999 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 ;; Changes
  30 ;;
  31 ;;  When        Who     What
  32 ;; ----------------------------------------------------------------------------
  33 ;;  1999-08-21  GB      - PAINT-DISPLAY-LIST: use R2::DRAW-BBOX-BACKGROUND.
  34 ;;                      - DISPLAY-LIST: new struct
  35 ;;                      - ACTIVE-EXTENTS, FIND-ACTIVE-LINK, PAINT-DISPLAY-LIST,
  36 ;;                        MAP-BOXEN-FOR-PT: changed accordingly
  37 ;;
  38 ;;  1999-08-19  GB      - PT-REPLACEMENT: Changed due to :%REPLACEMENT
  39 ;;                        attribute change; still returns the object only.
  40 ;;                      - FIND-ACTIVE-IN-ABOX* now also returns coordinates
  41 ;;                      - ACTIVE-LINK-MOUSE-DOCUMENTATION uses r2::command protocol
  42 ;;
  43
  44 (in-package :GUI)
  45
  46 (defparameter *home-page* "http://common-lisp.net/project/closure/")
  47
  48 (defvar *user-wants-images-p* t)
  49
  50 (defvar *closure-dpi* 96)
  51
  52 (defvar *zoom-factor* 1.0)
  53
  54 (defparameter *debug-submit-p* nil
  55   "Whether to dump the values about to be submit by a <FORM> to the server on the listener.")
  56
  57
  58
  59 (defstruct display-list
  60   document
  61   items)
  62
  63 ;;;
  64 ;;;  Events
  65 ;;;
  66
  67 (defclass event () ())
  68
  69 (defclass input-event (event)
  70   ((x      :initarg :x      :reader event-x)
  71    (y      :initarg :y      :reader event-y)
  72    (x-root :initarg :x-root :reader event-x-root)
  73    (y-root :initarg :y-root :reader event-y-root)
  74    (state  :initarg :state  :reader event-state)))
  75
  76 (defclass mouse-event (input-event)
  77   ())
  78
  79 (defclass motion-event (mouse-event) ())
  80
  81 (defclass pointer-motion-event (motion-event) ())
  82 (defclass enter-event (motion-event) ())
  83 (defclass leave-event (motion-event) ())
  84
  85 (defclass button-event (mouse-event)
  86   ((button :initarg :button :reader event-button)))
  87
  88 (defclass button-press-event (button-event) ())
  89 (defclass button-release-event (button-event) ())
  90
  91 (defclass exposure-event (event)
  92   ((region :initarg :region :reader event-region)))
  93
  94 (defclass configure-event (event)
  95   ((x      :initarg :x      :reader event-x)
  96    (y      :initarg :y      :reader event-y)
  97    (width  :initarg :width  :reader event-width)
  98    (height :initarg :height :reader event-height)))
  99
 100 (defclass map-notify-event (event) ())
 101
 102 (defclass key-event (input-event)
 103   ((key-code :initarg :key-code  :reader event-key-code)
 104    (key-name :initarg :key-name :reader event-key-name)))
 105
 106 (defclass key-press-event (key-event) ())
 107 (defclass key-release-event (key-event) ())
 108
 109 ;;
 110
 111 (defmethod translate-event ((event input-event) dx dy)
 112   (make-instance (type-of event)
 113     :x (+ (event-x event) dx)
 114     :y (+ (event-y event) dy)
 115     :x-root (event-x-root event)
 116     :y-root (event-y-root event)
 117     :state (event-state event)))
 118
 119 (defmethod translate-event ((event button-event) dx dy)
 120   (make-instance (type-of event)
 121     :x (+ (event-x event) dx)
 122     :y (+ (event-y event) dy)
 123     :x-root (event-x-root event)
 124     :y-root (event-y-root event)
 125     :state (event-state event)
 126     :button (event-button event)))
 127
 128 (defmethod translate-event ((event exposure-event) dx dy)
 129   (make-instance (type-of event)
 130     :region (transform-region (make-translation-transformation dx dy)
 131                               (event-region event))))
 132
 133 (defmethod translate-event ((event configure-event) dx dy)
 134   (make-instance (type-of event)
 135     :x (+ (event-x event) dx)
 136     :y (+ (event-y event) dy)
 137     :width (event-width event)
 138     :height (event-height event)))
 139
 140 (defmethod translate-event ((event map-notify-event) dx dy)
 141   (declare (ignore dx dy))
 142   (make-instance (type-of event)))
 143
 144 (defmethod translate-event ((event key-event) dx dy)
 145   (make-instance (type-of event)
 146     :x (+ (event-x event) dx)
 147     :y (+ (event-y event) dy)
 148     :x-root (event-x-root event)
 149     :y-root (event-y-root event)
 150     :state (event-state event)
 151     :key-code (event-key-code event)
 152     :key-name (event-key-name event)))
 153
 154 ;;
 155
 156 (defmethod print-object ((self mouse-event) sink)
 157   (format sink "#<~S ~S ~S ~S ~S ~S ~S>" (type-of self)
 158           :x (slot-value self 'x)
 159           :y (slot-value self 'y)
 160           :state (slot-value self 'state)))
 161
 162 (defmethod print-object ((self button-event) sink)
 163   (format sink "#<~S ~S ~S ~S ~S ~S ~S ~S ~S>" (type-of self)
 164           :x (slot-value self 'x)
 165           :y (slot-value self 'y)
 166           :state (slot-value self 'state)
 167           :button (slot-value self 'button)))
 168
 169 (defmethod print-object ((self exposure-event) sink)
 170   (format sink "#<~S ~S ~S>" (type-of self)
 171           :region (slot-value self 'region)))
 172
 173 (defmethod print-object ((self configure-event) sink)
 174   (format sink "#<~S ~S ~S ~S ~S ~S ~S ~S ~S>" (type-of self)
 175           :x (slot-value self 'x)
 176           :y (slot-value self 'y)
 177           :width (slot-value self 'width)
 178           :height (slot-value self 'height)))
 179
 180
 181 ;;;
 182 ;;;  Proxy Device
 183 ;;;
 184
 185 ;; a common vehicle to define GUI specific devices
 186
 187 (defclass proxy-device ()
 188   ((clonee :initarg :clonee) ))
 189
 190 (defmethod renderer:device-font-ascent ((self proxy-device) font)
 191   (with-slots (clonee) self
 192     (renderer:device-font-ascent clonee font)))
 193
 194 (defmethod renderer:device-dpi ((self proxy-device))
 195   (with-slots (clonee) self
 196     (renderer:device-dpi clonee)))
 197
 198 (defmethod renderer:device-font-descent ((self proxy-device) font)
 199   (with-slots (clonee) self
 200     (renderer:device-font-descent clonee font)))
 201
 202 (defmethod renderer:device-font-underline-position ((self proxy-device) font)
 203   (with-slots (clonee) self
 204     (renderer:device-font-underline-position clonee font)))
 205
 206 (defmethod renderer:device-font-underline-thickness ((self proxy-device) font)
 207   (with-slots (clonee) self
 208     (renderer:device-font-underline-thickness clonee font)))
 209
 210 (defmethod renderer:device-font-has-glyph-p ((self proxy-device) font index)
 211   (with-slots (clonee) self
 212     (renderer:device-font-has-glyph-p clonee font index)))
 213
 214 (defmethod renderer:device-font-glyph-width ((self proxy-device) font index)
 215   (with-slots (clonee) self
 216     (renderer:device-font-glyph-width clonee font index)))
 217
 218 (defmethod renderer:device-realize-font-desc ((self proxy-device) font-desc)
 219   (with-slots (clonee) self
 220     (renderer:device-realize-font-desc clonee font-desc)))
 221
 222 (defmethod renderer:device-font-database ((self proxy-device))
 223   (with-slots (clonee) self
 224     (renderer:device-font-database clonee )))
 225
 226 (defmethod renderer:scale-font-desc ((self proxy-device) fd size)
 227   (with-slots (clonee) self
 228     (renderer:scale-font-desc clonee fd size)))
 229
 230 (defmethod gui::make-image-replacement ((self proxy-device) doc &rest args &key url width height)
 231   (declare (ignore url width height))
 232   (with-slots (clonee) self
 233     (apply #'gui::make-image-replacement clonee doc args)))
 234
 235 ;;; ---- Some CLIM fake ---------------------------------------------------------------------------------
 236
 237 (defvar +black+ (xlib:make-color :red 0 :green 0 :blue 0))
 238 (defvar +white+ (xlib:make-color :red 1 :green 1 :blue 1))
 239
 240 ;;; ====================================================================================================
 241
 242 ;; gui:make-image-replacement device &key url width height -> replacement-object
 243 ;; r2:x11-draw-robj drawable gcontext replacement-object box x y -> ;
 244 ;; gui:ro/make-submit-button device &key pt label name size disabled-p read-only-p
 245 ;;   -> replacement-object (must obey to the ro/input protocol also)
 246 ;; gui:ro/make-text device &key pt name initial-value width max-length disabled-p read-only-p)
 247
 248
 249 ;; RO/INPUT protocol:
 250 ;;    slots: initial-value name disabled-p read-only-p pt
 251 ;;    RO/INPUT-DESTRUCT self -> ;
 252 ;;    RO/INPUT-CONTRIBUTION self -> alist ;
 253 ;;    RO/INPUT-RESET self -> ;
 254 ;;
 255
 256 ;;; ====================================================================================================
 257
 258 (defun parse-html-frameset-length (string &aux n)
 259   (cond ((and (>= (length string) 2)
 260               (char= (char string (1- (length string))) #\%)
 261               (every #'digit-char-p (subseq string 0 (1- (length string)))))
 262          (cons :% (parse-integer (subseq string 0 (1- (length string))))))
 263         ((and (>= (length string) 2)
 264               (char= (char string (1- (length string))) #\*)
 265               (every #'digit-char-p (subseq string 0 (1- (length string))))
 266               (>= (setq n (parse-integer (subseq string 0 (1- (length string))))) 1))
 267          (cons '* n))
 268         ((and (>= (length string) 2)
 269               (char= (char string 0) #\*)
 270               (every #'digit-char-p (subseq string 1))
 271               (>= (setq n (parse-integer (subseq string 1))) 1))
 272          (cons '* n))
 273         ((string= string "*")
 274          (cons '* 1))
 275         ((and (>= (length string) 1)
 276               (every #'digit-char-p string))
 277          (cons '1 (parse-integer string)))
 278         (t
 279          (warn "HTML frameset length value `~A' does not parse; using `1*' instead." string)
 280          (cons '* 1))))
 281
 282 (defun parse-html-frameset-length-list (string)
 283   (mapcar #'parse-html-frameset-length
 284           (mapcar (curry #'string-trim '(#\space #\tab #\newline #\return))
 285                   (split-by #\, string))))
 286
 287 (defun allot-frameset-lengthen (lengthen total)
 288   (let* ((n (length lengthen))
 289          (res (make-list n :initial-element 0)))
 290     ;; First allot the fixed and percentage values
 291     (dotimes (i n)
 292       (case (car (elt lengthen i))
 293         (:% (setf (elt res i) (* 1/100 (cdr (elt lengthen i)) total)))
 294         (1  (setf (elt res i) (cdr (elt lengthen i))))))
 295     ;; Now the proportional ones
 296     (let ((lack (max 0 (- total (reduce #'+ res))))
 297           (m (count '* lengthen :key #'car)))
 298       (dotimes (i n)
 299         (when (eql (car (elt lengthen i)) '*)
 300           (setf (elt res i) (* (/ (cdr (elt lengthen i)) m) lack))))
 301       ;; Adjust to given total value
 302       ;; Das muss noch anders werden:
 303       ;; Wenn wir genuegt werte haben, die nicht fest sind, sollten
 304       ;; wir diese nehmen. Das resultat sieht dann besser aus.
 305       (let ((rtotal (reduce #'+ res)))
 306         (if (zerop rtotal)
 307             (dotimes (i n)
 308               (setf (elt res i) (/ total n)))
 309           (dotimes (i n)
 310             (incf (elt res i) (* (- total rtotal) (/ (elt res i) rtotal)))))))
 311     ;; Finally round all values and adjust the first one according to
 312     ;; the rounding error.
 313     (dotimes (i n)
 314       (setf (elt res i) (round (elt res i))))
 315     (incf (elt res 0) (- total (reduce #'+ res)))
 316     ;; all done
 317     res))
 318
 319 ;;;; ----------------------------------------------------------------------------------------------------
 320
 321
 322 (defun pretty-color (x)
 323   (or (car (rassoc x css::*color-names* :test #'string-equal))
 324       x))
 325
 326 (defun make-device-for-display (dpy)
 327   (or (getf (xlib:display-plist dpy) 'device)
 328       (setf (getf (xlib:display-plist dpy) 'device)
 329         (make-instance 'ws/x11::x11-device :display dpy))))
 330
 331 (defun dump-source-of (url &optional (filename "/tmp/s"))
 332   (setq url (if (url:url-p url) url (url:parse-url url)))
 333   (with-open-file (sink filename
 334                    :direction :output
 335                    :if-exists :new-version
 336                    :element-type '(unsigned-byte 8))
 337     (netlib:with-open-document ((input mime-type) url)
 338       (declare (ignore mime-type))
 339       (netlib::copy-gstream input (glisp:cl-byte-stream->gstream sink))))
 340   (format T "~&;; Source of ~A dumped to ~S." url filename))
 341
 342 ;;;; ------------------------------------------------------------------------------------------
 343 ;;;;  FORMS
 344 ;;;;
 345
 346 (defun input-name-equal-p (name1 name2)
 347   (and name1 name2
 348        (string-equal name1 name2)))
 349
 350 (defun find-form-element (pt)
 351   "Finds the <FORM> element 'pt' belongs to. May return NIL, if no FORM is present."
 352   (cond ((null pt) nil)
 353         ((eq (sgml:gi pt) :FORM) pt)
 354         ((find-form-element (sgml:pt-parent pt)))))
 355
 356 (defun map-input-elements (fun form)
 357   "Call function `fun' on all input elements within the FORM element `form'."
 358   (assert (eq (sgml:gi form) :FORM))
 359   (sgml:map-pt (lambda (x)
 360                  (when (input-element-p x)
 361                    (funcall fun x)))
 362                form))
 363
 364 (defun input-element-p (elm)
 365   "Is the element `elm' an HTML input element?
 366    ISINDEX is *not* consided to be an input element."
 367   (member (sgml:gi elm) '(:input :button :select :textarea)))
 368
 369 (defun pt-replacement (pt)
 370   (car (r2::pt-%replacement pt nil)))
 371
 372 (defun collect-form-values (form-elm)
 373   (let ((res nil))
 374     (map-input-elements (lambda (x)
 375                           (let ((obj (pt-replacement x)))
 376                             (when (typep obj 'ro/input)
 377                               (setf res (append res (ro/input-contribution obj))))))
 378                         form-elm)
 379     res))
 380
 381 (defun reset-form (form-elm)
 382   (map-input-elements (lambda (x)
 383                         (let ((obj (pt-replacement x)))
 384                           (when (typep obj 'ro/input)
 385                             (ro/input-reset obj))))
 386                       form-elm))
 387
 388 (defun encode-values-via-application/x-www-form-urlencoded (values)
 389   (url::unparse-query values))
 390
 391 ;;;;
 392
 393 ;;;; ------------------------------------------------------------------------------------------
 394 ;;;;  profiling
 395 ;;;;
 396
 397 (defclass prim-ht-view ()
 398   ((display-list        :initform nil)
 399    (active-pt           :initform nil)
 400    (active-link         :initform nil) ))
 401
 402 ;;; --------------------------------------------------------------------------------
 403
 404 (defvar cl-user::*html-dtd* nil)
 405
 406 (defun init-closure ()
 407   ;; Init general closure stuff
 408   #||
 409   (unless *ht*
 410     (format T "~&;; Slurping hyphenation table ...")
 411     (setf *ht* (slurp-patterns "resources/patterns/english.ptn"))
 412     (princ " done.") )
 413   ||#
 414   (unless cl-user::*html-dtd*
 415     (cond
 416      ;; xxx hack
 417      ((probe-file (compile-file-pathname "html-dtd.lisp"))
 418       (format T "~&;; Loading DTD ")
 419       (setf cl-user::*html-dtd* (sgml::undump-dtd "html-dtd"))
 420       (princ " done.")
 421       (finish-output))
 422      (t
 423       (format T "~&;; Parsing DTD ")
 424       (sgml:slurp-catalog (url:parse-url "file://closure/resources/dtd/catalog"))
 425       (setf cl-user::*html-dtd* (sgml:parse-dtd '(:public "-//W3C//DTD HTML 4.0 Frameset//EN")))
 426       (princ " done.")
 427       (finish-output))))
 428
 429   (unless r2::*default-style-sheet*
 430     (format T "~&;; Parsing default style sheet ...")
 431     (setf r2::*default-style-sheet*
 432           (css::parse-style-sheet-from-url (url:parse-url "file://closure/resources/css/default.css")
 433                                            :name "Closure Default Style Sheet")))
 434   (princ " done.")
 435   (finish-output)
 436   (values))
 437
 438
 439 (defclass ro/input ()
 440   ((initial-value :initarg :initial-value)
 441    (name          :initarg :name)
 442    (disabled-p    :initarg :disabled-p :initform nil)
 443    (read-only-p   :initarg :read-only-p :initform nil)
 444    (pt            :initarg :pt)
 445    (document      :initarg :document)))
 446
 447 ;;;;
 448
 449 (defstruct option-menu-option
 450   label         ;the entries label as in DTD (a ROD)
 451   selected-p
 452   disabled-p    ;disabled? Note: DTD says it doesn't apply here?
 453   value         ;the value
 454   content)      ;the entries content as in DTD (a ROD)
 455
 456 (defstruct option-menu-option-group
 457   disabled-p
 458   label
 459   children)
 460
 461
 462
 463 ;;;;
 464
 465
 466
 467