1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-USER; -*-
2 ;;; ---------------------------------------------------------------------------
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
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.
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.
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.
25 ;; $Log: clim-gui.lisp,v $
26 ;; Revision 1.1.1.1 2002-07-22 02:27:22 gilbert
30 (in-package :CLIM-USER
)
37 (defclass closure-pane
(sheet-multiple-child-mixin
41 (define-application-frame closure
()
44 (canvas (make-pane 'closure-pane
55 :display-function
'aux-display
56 :display-time
:command-loop
)
57 (status :pointer-documentation
58 :text-style
(make-text-style :sans-serif
:roman
:normal
)
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/"
73 :pointer-documentation
:width
5 :max-width
+fill
+ :height
20
76 (menu-bar (climi::make-menu-bar
'menubar-command-table
:height
25)))
83 (climi::scrolling
(:width
830 :height
600 :min-height
400 :max-height
20000)
88 (labelling (:label
"Auxillary Pane")
99 (climi::scrolling
(:width
830 :height
600 :min-height
400 :max-height
20000)
105 ;;(:top-level (closure-frame-top-level . nil))
108 (make-command-table 'menubar-command-table
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
)
117 (make-command-table 'appearance-command-table
:errorp nil
118 :menu
'(("Show Listener" :command com-show-listener
)
119 ("Hide Listener" :command com-hide-listener
)))
121 (define-closure-command com-show-listener
()
122 (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame
* 'interactor
))) t
))
124 (define-closure-command com-hide-listener
()
125 (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame
* 'interactor
))) nil
))
127 (make-command-table 'file-command-table
129 :menu
'(("Quit" :command com-quit
)))
131 (make-command-table 'go-command-table
133 :menu
'(("Back" :command com-back
)
134 ("Forward" :command com-forward
)
135 ("Home" :command com-home
)))
137 (make-command-table 'view-command-table
139 :menu
'(("Zoom" :menu zoom-command-table
)))
141 (make-command-table 'zoom-command-table
143 :menu
'(("Zoom In" :command com-zoom-in
)
144 ("Zoom Out" :command com-zoom-out
)
145 ("Zoom 100%" :command com-zoom-100%
)))
147 (make-command-table 'bookmarks-command-table
149 :menu
'(("Add" :command com-add-bookmark
)
150 ;;("Forward" :command com-forward)
154 (defparameter *shopping-list
* nil
)
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
))
163 (define-closure-command com-add-to-shopping-list
((url 'url
))
164 (setf *shopping-list
* (append *shopping-list
* (list url
)))
166 (setf (pane-needs-redisplay (sheet-parent (find-pane-named *application-frame
*
170 (defun aux-display (frame pane
)
171 (dolist (k *shopping-list
*)
175 (define-closure-command nop
()
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
))
187 (define-closure-command com-foo
()
188 (let ((*standard-output
* *trace-output
*))
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
*))
200 (define-presentation-type url
())
201 (define-presentation-type r2
::pt
())
202 (define-presentation-type r2
::hyper-link
())
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 "))
209 (with-text-style (*standard-output
* (make-text-style :sans-serif
:roman
:normal
))
211 (let ((*standard-output
* *trace-output
*))
214 (defun make-google-search-url (string)
217 (url:make-url
:query
(list
219 (cons "ie" "ISO-8859-1")
221 (url:parse-url
"http://www.google.com/search"))))
223 (define-closure-command com-reverse-lookup
((url 'url
))
224 (let ((*standard-output
* *trace-output
*))
226 (make-google-search-url (format nil
"link:~A" url
)))))
228 (define-closure-command com-search-google
((what 'string
))
229 (com-visit-url (make-google-search-url what
)))
232 (define-closure-command com-visit-string
((url 'string
:gesture
:select
))
233 (let ((*standard-output
* *trace-output
*))
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
))))
240 (define-closure-command com-describe-pt
((pt 'r2
::pt
:gesture
:describe
))
243 (define-closure-command com-quit
()
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
*
267 (loop for port in climi
::*all-ports
*
268 do
(destroy-port port
))
269 (setq climi
::*all-ports
* nil
)
271 (setf *frame
* (make-application-frame 'closure
))
272 (setf *pane
* (find-pane-named *frame
* 'canvas
))
273 (funcall;;progn ;;clim-sys:make-process
275 (run-frame-top-level *frame
*))))
277 (defun write-status (string)
278 (window-clear (find-pane-named *frame
* 'status
))
279 (write-string string
(find-pane-named *frame
* 'status
)))
282 (defun foo (&optional
(url "file:/home/gilbert/work/closure/simple.html")) ;;http://127.1/~gilbert/tests/"))
284 (clim-sys:make-process
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
*)))
292 (xlib:display-finish-output
(clim-clx::clx-port-display
(find-port))))))
294 (defvar *current-document
*)
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
306 :pt
(clue-gui2::make-pt-from-input
308 (netlib::get-header-field header
:content-type
) url
) )))
309 (write-status "Rendering ...")
310 (setf *current-document
* doc
)
312 (multiple-value-bind (x1 y1 x2 y2
)
316 (r2::document-pt doc
)
320 (clim:change-space-requirements
*pane
* :width x2
:height y2
)))
321 (write-status "Done.")
324 (defun parse-x11-color (string &aux sym
)
325 (cond ((and (= (length string
) 4) (char= (char string
0) #\
#))
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) #\
#))
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) #\
#))
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
)))
343 (clim:colorp
(symbol-value sym
)))
346 (warn "~S: foo color: ~S." 'parse-x11-color string
)
351 (defun invoke-for-all-links (cont &optional
(doc *current-document
*)
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
)))
359 (defmacro over-all-links
((var) &body body
)
360 `(invoke-for-all-links (lambda (,var
) .
,body
)))
362 (define-closure-command com-fetch-files-matching
((pattern 'string
))
363 (over-all-links (url)
364 (when (equal (url:url-extension url
) pattern
)
367 (define-closure-command com-search-clx-manual
((query 'string
))
371 (url:make-url
:query
(list
373 (url:parse-url
"http://127.1/clxman/doc-index.cgi")))))
375 (define-closure-command com-search-java-doc
((query 'string
))
379 (url:make-url
:query
(list
381 (url:parse-url
"http://127.1/~delly/javadoc/doc-index.pl")))))
383 (define-closure-command com-bar
()
384 (clim-sys:make-process
386 (run-frame-top-level (make-application-frame 'shopping-list
)))))
390 (define-application-frame shopping-list
()
393 (shoping-list :application
400 (shopping-list-top-level)))
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
)))
407 (clim-extensions:simple-event-loop
))
412 (defmethod clim:sheet-native-transformation
((sheet null
)) clim
:+identity-transformation
+)
413 (defmethod clim:medium-sheet
((sheet sheet
)) sheet
)
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.
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
)))
431 (define-closure-command bar
()
432 ;; (window-clear *pane*)
433 ;; (with-output-as-gadget *pane*
435 (make-pane-1 (frame-manager *application-frame
*)
437 'push-button
:label
"Click me")))
438 (draw-gadget *pane
* gadget
100 200)))
441 (define-presentation-translator url-from-string
446 (define-presentation-method accept
((type url
)
448 (view (eql +textual-view
+))
449 &key default default-type
)
450 (url:parse-url
(accept 'string
:stream stream
:prompt nil
)))
453 (define-closure-command com-search-google
((what 'string
))
456 (url:make-url
:query
`(("hl" .
"en")
457 ("ie" .
"ISO-8859-1")
459 (url:parse-url
"http://www.google.com/search"))))
462 (define-closure-command com-init-test
()
467 (url:parse-url
"http://www.w3.org/Style/CSS/Test/CSS1/current/")))
575 (define-closure-command com-next-test
()
576 (com-visit-url (pop *test-urls
*)))