src/gui/clim-gui.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-USER; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: CLIM GUI
   4 ;;;   Created: 2002-07-22
   5 ;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
   6 ;;;   License: GPL (See file COPYING for details).
   7 ;;;       $Id: clim-gui.lisp,v 1.1.1.1 2002-07-22 02:27:22 gilbert Exp $
   8 ;;; ---------------------------------------------------------------------------
   9 ;;;  (c) copyright 2002 by Gilbert Baumann
  10
  11 ;;; This program is free software; you can redistribute it and/or modify
  12 ;;; it under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 2 of the License, or
  14 ;;; (at your option) any later version.
  15 ;;;
  16 ;;; This program is distributed in the hope that it will be useful,
  17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with this program; if not, write to the Free Software
  23 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  24
  25 ;; $Log: clim-gui.lisp,v $
  26 ;; Revision 1.1.1.1  2002-07-22 02:27:22  gilbert
  27 ;; imported sources
  28 ;;
  29
  30 (in-package :CLIM-USER)
  31 (use-package :clim)
  32
  33 ;;;;;;;
  34
  35 (defvar *medium*)
  36
  37 (defclass closure-pane (sheet-multiple-child-mixin
  38                         application-pane)
  39   ())
  40
  41 (define-application-frame closure ()
  42   ()
  43   (:panes
  44    (canvas (make-pane 'closure-pane
  45             :height 2000
  46             :width 800
  47             :display-time nil))
  48    (aux :application
  49     :height 300
  50     :width 300
  51     :min-width 100
  52     :min-height 100
  53     :max-width 300
  54     :max-height 20000
  55     :display-function 'aux-display
  56     :display-time :command-loop)
  57    (status :pointer-documentation
  58     :text-style (make-text-style :sans-serif :roman :normal)
  59     :scroll-bar nil
  60     :height 20
  61     :width 200
  62     :background +black+
  63     :foreground +white+)
  64    (interactor :interactor :height 200 :min-height 50 :max-height 200)
  65    (back (make-pane 'push-button :label "Back"))
  66    (forward (make-pane 'push-button :label "Forward"))
  67    (stop (make-pane 'push-button :label "Stop"))
  68    (url-entry (make-pane 'text-field
  69                :value "http://www.w3.org/"
  70                :max-width +fill+
  71                :background +white+))
  72    (wholine
  73     :pointer-documentation :width 5 :max-width +fill+ :height 20
  74     :foreground +white+
  75     :background +black+)
  76    (menu-bar (climi::make-menu-bar 'menubar-command-table :height 25)))
  77   (:layouts
  78    (default
  79        (vertically ()
  80          menu-bar
  81          (horizontally ()
  82            (vertically ()
  83              (climi::scrolling (:width 830 :height 600 :min-height 400 :max-height 20000)
  84                                canvas)
  85              (vertically ()
  86                interactor))
  87            #+NIL
  88            (labelling (:label "Auxillary Pane")
  89              aux))
  90          (horizontally ()
  91            wholine
  92            2
  93            (200 status))))
  94    (hidden-listener
  95        (vertically ()
  96          menu-bar
  97          (horizontally ()
  98            (vertically ()
  99              (climi::scrolling (:width 830 :height 600 :min-height 400 :max-height 20000)
 100                                canvas)) )
 101          (horizontally ()
 102            wholine
 103            2
 104            (200 status)))))
 105   ;;(:top-level (closure-frame-top-level . nil))
 106   )
 107
 108 (make-command-table 'menubar-command-table
 109                     :errorp nil
 110                     :menu '(("File" :menu file-command-table)
 111                             ("Go"   :menu go-command-table)
 112                             ("Bookmarks"   :menu bookmarks-command-table)
 113                             ("View"     :menu view-command-table)
 114                             ("Appearance" :menu appearance-command-table)
 115                             ))
 116
 117 (make-command-table 'appearance-command-table :errorp nil
 118                     :menu '(("Show Listener" :command com-show-listener)
 119                             ("Hide Listener" :command com-hide-listener)))
 120
 121 (define-closure-command com-show-listener ()
 122   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t))
 123
 124 (define-closure-command com-hide-listener ()
 125   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) nil))
 126
 127 (make-command-table 'file-command-table
 128                     :errorp nil
 129                     :menu '(("Quit" :command com-quit)))
 130
 131 (make-command-table 'go-command-table
 132                     :errorp nil
 133                     :menu '(("Back" :command com-back)
 134                             ("Forward" :command com-forward)
 135                             ("Home" :command com-home)))
 136
 137 (make-command-table 'view-command-table
 138                     :errorp nil
 139                     :menu '(("Zoom"    :menu    zoom-command-table)))
 140
 141 (make-command-table 'zoom-command-table
 142                     :errorp nil
 143                     :menu '(("Zoom In" :command com-zoom-in)
 144                             ("Zoom Out" :command com-zoom-out)
 145                             ("Zoom 100%" :command com-zoom-100%)))
 146
 147 (make-command-table 'bookmarks-command-table
 148                     :errorp nil
 149                     :menu '(("Add" :command com-add-bookmark)
 150                             ;;("Forward" :command com-forward)
 151                             ))
 152
 153
 154 (defparameter *shopping-list* nil)
 155
 156
 157
 158 (define-closure-command com-hide-aux-pane ()
 159   (setf (sheet-enabled-p (sheet-parent(find-pane-named *application-frame* 'aux))) nil))
 160 (define-closure-command com-show-aux-pane ()
 161   (setf (sheet-enabled-p (sheet-parent(find-pane-named *application-frame* 'aux))) t))
 162
 163 (define-closure-command com-add-to-shopping-list ((url 'url))
 164   (setf *shopping-list* (append *shopping-list* (list url)))
 165   #+NIL
 166   (setf (pane-needs-redisplay (sheet-parent (find-pane-named *application-frame*
 167                                                              'aux)))
 168         t))
 169
 170 (defun aux-display (frame pane)
 171   (dolist (k *shopping-list*)
 172     (present k 'url)
 173     (terpri)))
 174
 175 (define-closure-command nop ()
 176   )
 177
 178 (defmethod closure-frame-top-level ((frame application-frame)
 179                                        &key (command-parser 'command-line-command-parser)
 180                                        (command-unparser 'command-line-command-unparser)
 181                                        (partial-command-parser
 182                                         'command-line-read-remaining-arguments-for-partial-command)
 183                                        (prompt "Command: "))
 184   (declare (ignore command-parser command-unparser partial-command-parser prompt))
 185   (clim-extensions:simple-event-loop))
 186
 187 (define-closure-command com-foo ()
 188   (let ((*standard-output* *trace-output*))
 189     (let #+CMU
 190       ((*standard-output* sys:*tty*)
 191        (*standard-input* sys:*tty*)
 192        (*debug-io* sys:*tty*)
 193        (*error-output* sys:*tty*)
 194        (*trace-output* sys:*tty*))
 195       #-CMU
 196       ()
 197       (foo)
 198       )))
 199
 200 (define-presentation-type url ())
 201 (define-presentation-type r2::pt ())
 202 (define-presentation-type r2::hyper-link ())
 203
 204 (define-closure-command com-visit-url ((url 'url :gesture :select))
 205   (let ((*standard-output* *query-io*)) ;;(find-pane-named *frame* 'interactor)))
 206     (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal))
 207       (format t "~%You are visiting "))
 208     (present url 'url)
 209     (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal))
 210       (format t ".~%")))
 211   (let ((*standard-output* *trace-output*))
 212     (foo url)))
 213
 214 (defun make-google-search-url (string)
 215   (url:unparse-url
 216    (url:merge-url
 217     (url:make-url :query (list
 218                           (cons "hl" "en")
 219                           (cons "ie" "ISO-8859-1")
 220                           (cons "q" string)))
 221     (url:parse-url "http://www.google.com/search"))))
 222
 223 (define-closure-command com-reverse-lookup ((url 'url))
 224   (let ((*standard-output* *trace-output*))
 225     (com-visit-url
 226      (make-google-search-url (format nil "link:~A" url)))))
 227
 228 (define-closure-command com-search-google ((what 'string))
 229   (com-visit-url (make-google-search-url what)))
 230
 231
 232 (define-closure-command com-visit-string ((url 'string :gesture :select))
 233   (let ((*standard-output* *trace-output*))
 234     (foo url)))
 235
 236 (define-closure-command com-visit-hyper-link ((url 'r2::hyper-link :gesture :select))
 237   (let ((*standard-output* *trace-output*))
 238     (foo (r2::hyper-link-url url))))
 239
 240 (define-closure-command com-describe-pt ((pt 'r2::pt :gesture :describe))
 241   (print pt))
 242
 243 (define-closure-command com-quit ()
 244   (unix:unix-exit 0))
 245
 246 (defvar *frame*)
 247 (defvar *pane*)
 248
 249 (defun foo-init ()
 250   (setf CLUE-GUI2::*PIXMAP-CACHE* nil)
 251   (setf CLUE-GUI2::*PIXMAP-CACHE* nil)
 252   (setf CLUE-GUI2::*DCACHE* nil)
 253   (setf climi::*3d-dark-color*   (make-gray-color .45))
 254   (setf climi::*3d-normal-color* (make-gray-color .75))
 255   (setf climi::*3d-light-color*  (make-gray-color .92))
 256   (setf climi::*3d-inner-color*  (make-gray-color .65))
 257   (setf clim-clx::*clx-text-sizes*
 258         '(:normal 12
 259           :tiny 8
 260           :very-small 10
 261           :small 10
 262           :large 14
 263           :very-large 18
 264           :huge 24))
 265   (gui::init-closure)
 266   ;;;+XXX
 267   (loop for port in climi::*all-ports*
 268       do (destroy-port port))
 269   (setq climi::*all-ports* nil)
 270   ;;;-XXX
 271   (setf *frame* (make-application-frame 'closure))
 272   (setf *pane*  (find-pane-named *frame* 'canvas))
 273   (funcall;;progn ;;clim-sys:make-process
 274    (lambda ()
 275      (run-frame-top-level *frame*))))
 276
 277 (defun write-status (string)
 278   (window-clear (find-pane-named *frame* 'status))
 279   (write-string string (find-pane-named *frame* 'status)))
 280
 281
 282 (defun foo (&optional (url "file:/home/gilbert/work/closure/simple.html")) ;;http://127.1/~gilbert/tests/"))
 283   ;;
 284   (clim-sys:make-process
 285    (lambda ()
 286      (window-clear *pane*)
 287      (setf (gadget-value (find-pane-named *frame* 'url-entry)) url)
 288      (progn;;with-sheet-medium (medium *pane*)
 289        (let ((*medium* *pane*))
 290          (let ((device (make-instance 'closure/clim-device::clim-device :medium *medium*)))
 291            (baz device url))))
 292      (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))))
 293
 294 (defvar *current-document*)
 295
 296 (defun baz (device url)
 297   (setq url (r2::parse-url* url))
 298   (let ((request (clue-gui2::make-request :url url :method :get)))
 299     (multiple-value-bind (io header) (clue-gui2::open-document-4 request)
 300       (write-status "Fetching Document ...")
 301       (let* ((doc (make-instance 'r2::document
 302                                  :processes-hooks nil
 303                                  :location
 304                                  (r2::parse-url* url)
 305                                  :http-header header
 306                                  :pt (clue-gui2::make-pt-from-input
 307                                       io
 308                                       (netlib::get-header-field header :content-type) url) )))
 309         (write-status "Rendering ...")
 310         (setf *current-document* doc)
 311         (time
 312          (multiple-value-bind (x1 y1 x2 y2)
 313              (r2::render-pt
 314               device
 315               doc
 316               (r2::document-pt doc)
 317               700                       ;xxx width
 318               t                         ;?
 319               0)
 320            (clim:change-space-requirements *pane* :width x2 :height y2)))
 321         (write-status "Done.")
 322         '(describe doc)))))
 323
 324 (defun parse-x11-color (string &aux sym)
 325   (cond ((and (= (length string) 4) (char= (char string 0) #\#))
 326          (make-rgb-color
 327           (/ (parse-integer string :start 1 :end 2 :radix 16) #xF)
 328           (/ (parse-integer string :start 2 :end 3 :radix 16) #xF)
 329           (/ (parse-integer string :start 3 :end 4 :radix 16) #xF)))
 330         ((and (= (length string) 7) (char= (char string 0) #\#))
 331          (make-rgb-color
 332           (/ (parse-integer string :start 1 :end 3 :radix 16) #xFF)
 333           (/ (parse-integer string :start 3 :end 5 :radix 16) #xFF)
 334           (/ (parse-integer string :start 5 :end 7 :radix 16) #xFF)))
 335         ((and (= (length string) 13) (char= (char string 0) #\#))
 336          (make-rgb-color
 337           (/ (parse-integer string :start 1 :end 5 :radix 16) #xFFFF)
 338           (/ (parse-integer string :start 5 :end 9 :radix 16) #xFFFF)
 339           (/ (parse-integer string :start 9 :end 13 :radix 16) #xFFFF)))
 340         ((and (setf sym (find-symbol (concatenate 'string "+" (string-upcase string) "+")
 341                                      (find-package :clim)))
 342               (boundp sym)
 343               (clim:colorp (symbol-value sym)))
 344          (symbol-value sym))
 345         (t
 346          (warn "~S: foo color: ~S." 'parse-x11-color string)
 347          +red+)))
 348
 349 ;;;;;
 350
 351 (defun invoke-for-all-links (cont &optional (doc *current-document*)
 352                                   &aux url)
 353   (sgml:map-pt (lambda (pt)
 354                  (cond ((and (eq (sgml:gi pt) :A)
 355                              (setf url (r2::pt-effective-url-attr doc pt :href)))
 356                         (funcall cont url))))
 357    (r2::document-pt doc)))
 358
 359 (defmacro over-all-links ((var) &body body)
 360   `(invoke-for-all-links (lambda (,var) .,body)))
 361
 362 (define-closure-command com-fetch-files-matching ((pattern 'string))
 363   (over-all-links (url)
 364                   (when (equal (url:url-extension url) pattern)
 365                     (print url))))
 366
 367 (define-closure-command com-search-clx-manual ((query 'string))
 368   (com-visit-url
 369    (url:unparse-url
 370     (url:merge-url
 371      (url:make-url :query (list
 372                            (cons "q" query)))
 373      (url:parse-url "http://127.1/clxman/doc-index.cgi")))))
 374
 375 (define-closure-command com-search-java-doc ((query 'string))
 376   (com-visit-url
 377    (url:unparse-url
 378     (url:merge-url
 379      (url:make-url :query (list
 380                            (cons "q" query)))
 381      (url:parse-url "http://127.1/~delly/javadoc/doc-index.pl")))))
 382
 383 (define-closure-command com-bar ()
 384   (clim-sys:make-process
 385    (lambda ()
 386      (run-frame-top-level (make-application-frame 'shopping-list)))))
 387
 388 ;;;;
 389
 390 (define-application-frame shopping-list ()
 391   ()
 392   (:panes
 393    (shoping-list :application
 394     :width 400
 395     :height 600))
 396   (:layouts
 397    (:default
 398     shoping-list))
 399   (:top-level
 400    (shopping-list-top-level)))
 401
 402 (defmethod shopping-list-top-level ((frame application-frame) &key)
 403   (let ((*standard-input* (frame-standard-input frame))
 404         (*standard-output* (frame-standard-output frame))
 405         (*query-io* (frame-query-io frame)))
 406     (catch 'exit
 407       (clim-extensions:simple-event-loop))
 408     (frame-exit frame)))
 409
 410 ;;;;;;;;
 411
 412 (defmethod clim:sheet-native-transformation ((sheet null)) clim:+identity-transformation+)
 413 (defmethod clim:medium-sheet ((sheet sheet)) sheet)
 414
 415
 416 ;;;;;;;;
 417
 418 ;; Now finally it would be good, if we had something like
 419 ;; SPACE-REQUIREMENT-BASELINE, so that we can align these gadgets at
 420 ;; the baseline. This however is not really sufficient, since the
 421 ;; baseline of a gadget depends on its assigned size.
 422
 423 (defmethod draw-gadget (sheet gadget x y)
 424   (let ((sq (compose-space gadget)))
 425     (allocate-space gadget
 426                     (space-requirement-width sq)
 427                     (space-requirement-height sq))
 428     (move-sheet gadget x y)
 429     (sheet-adopt-child sheet gadget)))
 430
 431 (define-closure-command bar ()
 432 ;;  (window-clear *pane*)
 433 ;;  (with-output-as-gadget *pane*
 434   (let ((gadget
 435          (make-pane-1 (frame-manager *application-frame*)
 436                       *application-frame*
 437                       'push-button :label "Click me")))
 438     (draw-gadget *pane* gadget 100 200)))
 439
 440
 441 (define-presentation-translator url-from-string
 442     (string url closure)
 443   (x)
 444   (url:parse-url x))
 445
 446 (define-presentation-method accept ((type url)
 447                                     stream
 448                                     (view (eql +textual-view+))
 449                                     &key default default-type)
 450   (url:parse-url (accept 'string :stream stream :prompt nil)))
 451
 452
 453 (define-closure-command com-search-google ((what 'string))
 454   (com-visit-url
 455    (url:merge-url
 456     (url:make-url :query `(("hl" . "en")
 457                            ("ie" . "ISO-8859-1")
 458                            ("q"  . ,string)))
 459     (url:parse-url "http://www.google.com/search"))))
 460
 461
 462 (define-closure-command com-init-test ()
 463   (setf *test-urls*
 464         (mapcar (lambda (x)
 465                   (url:merge-url
 466                    (url:parse-url x)
 467                    (url:parse-url "http://www.w3.org/Style/CSS/Test/CSS1/current/")))
 468                 '("test11.htm"
 469                   "test12.htm"
 470                   "test13.htm"
 471                   "test14.htm"
 472                   "test15.htm"
 473                   "test16.htm"
 474                   "test17.htm"
 475                   "test21.htm"
 476                   "test23.htm"
 477                   "test24.htm"
 478                   "test25.htm"
 479                   "test26.htm"
 480                   "test31.htm"
 481                   "test32.htm"
 482                   "test411.htm"
 483                   "test412.htm"
 484                   "test414.htm"
 485                   "test42.htm"
 486                   "test43.htm"
 487                   "test44.htm"
 488                   "test45.htm"
 489                   "test522.htm"
 490                   "test523.htm"
 491                   "test524.htm"
 492                   "test525.htm"
 493                   "test526.htm"
 494                   "test527.htm"
 495                   "test531.htm"
 496                   "test532.htm"
 497                   "test533.htm"
 498                   "test534.htm"
 499                   "test535.htm"
 500                   "test536.htm"
 501                   "test537.htm"
 502                   "test541.htm"
 503                   "test542.htm"
 504                   "test543.htm"
 505                   "test544.htm"
 506                   "test545.htm"
 507                   "test546.htm"
 508                   "test547.htm"
 509                   "test548.htm"
 510                   "test5501.htm"
 511                   "test5501b.htm"
 512                   "test5502.htm"
 513                   "test5502b.htm"
 514                   "test5503.htm"
 515                   "test5503b.htm"
 516                   "test5504.htm"
 517                   "test5504b.htm"
 518                   "test5505.htm"
 519                   "test5505b.htm"
 520                   "test5506.htm"
 521                   "test5506b.htm"
 522                   "test5507.htm"
 523                   "test5507b.htm"
 524                   "test5508.htm"
 525                   "test5508b.htm"
 526                   "test5509.htm"
 527                   "test5509b.htm"
 528                   "test5510.htm"
 529                   "test5510b.htm"
 530                   "test5511.htm"
 531                   "test5511b.htm"
 532                   "test5512.htm"
 533                   "test5512b.htm"
 534                   "test5513.htm"
 535                   "test5513b.htm"
 536                   "test5514.htm"
 537                   "test5514b.htm"
 538                   "test5515.htm"
 539                   "test5515b.htm"
 540                   "test5516.htm"
 541                   "test5516b.htm"
 542                   "test5517.htm"
 543                   "test5517b.htm"
 544                   "test5518.htm"
 545                   "test5518b.htm"
 546                   "test5519.htm"
 547                   "test5519b.htm"
 548                   "test5520.htm"
 549                   "test5520b.htm"
 550                   "test5521.htm"
 551                   "test5521b.htm"
 552                   "test5522.htm"
 553                   "test5522b.htm"
 554                   "test5523.htm"
 555                   "test5524.htm"
 556                   "test5525.htm"
 557                   "test5525b.htm"
 558                   "test5525c.htm"
 559                   "test5525d.htm"
 560                   "test5526.htm"
 561                   "test5526b.htm"
 562                   "test5526c.htm"
 563                   "test561.htm"
 564                   "test562.htm"
 565                   "test563.htm"
 566                   "test564.htm"
 567                   "test565.htm"
 568                   "test566.htm"
 569                   "test61.htm"
 570                   "test62.htm"
 571                   "test63.htm"
 572                   "test64.htm"
 573                   "test71.htm"))))
 574
 575 (define-closure-command com-next-test ()
 576   (com-visit-url (pop *test-urls*)))
 577
 578