;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - draw-urlpath-tree.lisp
;; Description - tiny CLIM applictaion to draw a urlpath tree
;; Author - Tim Bradshaw (tfb at lostwithiel)
;; Created On - Mon Jan 31 01:34:53 2000
;; Last Modified On - Mon Jun 25 12:55:41 2001
;; Last Modified By - Gail Anderson (ga at lostwithiel)
;; Update Count - 53
;; Status - Unknown
;;
;; $Id: draw-urlpath-tree.lisp,v 1.1 2003/01/23 22:19:15 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 2000, 2001 Cley Limited
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
;;;
;;; You can contact Cley Limited by emailing cley@cley.com.
;;; To use this standalone
;(defpackage :draw-urlpath-tree
; (:nicknames :dut)
; (:use :clim-lisp :clim :upt)
; (:export :draw-urlpath-tree))
(in-package :dut)
;;;; Drawing URL trees
;;;
;;; This paints pages with dangling links red, which is nice, as well
;;; as giving a little `describe' pane with information about which
;;; links from a page are broken. A real version would do a lot more
;;; of course (menus of links from each page passed to netscape or
;;; something).
;;;
;;; In fact the API given in the exercise is somewhat deficient,
;;; because the final function should return a list of pages with
;;; their dangling links -- just knowing that these n links are broken
;;; in some huge tree is not that useful. Fortunately this is trivial
;;; to write based on the functionality that already exists (this
;;; program essentially does that).
;;;
(define-application-frame piccy ()
((tree :initarg :tree
:accessor piccy-tree)
(urp :initarg :unresolved-pointer-predicate
:accessor piccy-urp)
(df :initarg :describer-function
:accessor piccy-df)
(described-object :accessor piccy-described-object
:initform nil))
(:panes
(main :application
:display-function 'piccy-draw
:display-time nil ;never redisplay (need to restart)
:width 700
:height 500
:text-cursor nil)
(describe :application
:display-function 'piccy-describe
;; keep looking at the top left rather than scrolling
:end-of-line-action ':allow
:end-of-page-action ':allow))
(:layouts
(:default (vertically ()
(4/5 main)
(1/5 describe))))
(:menu-bar nil))
;;; Binding defaulting. These might be kind of useful in general I
;;; guess, but are now OTT here.
;;;
(defmacro let-default (bindings &body body)
`(let ,(mapcar #'(lambda (b)
(etypecase b
(symbol
b)
(list
(destructuring-bind (name val) b
`(,name (or ,name ,val))))))
bindings)
,@body))
(defmacro setf-default (&rest vars-and-values)
`(setf ,@(loop for vb = vars-and-values then (cddr vb)
while vb
for var = (first vb) and val = (second vb)
collect var
collect `(or ,var ,val))))
(defmethod initialize-instance :after ((frame piccy) &key)
(setf-default (piccy-urp frame)
#'(lambda (pa tree)
(dolist (a (page-attributes-links pa) nil)
(when (not (urlpath-value-in-upt a tree))
(return t))))
(piccy-df frame)
#'(lambda (o tree s)
(piccy-default-describer o tree s))))
(define-presentation-type page-attributes ())
(defmethod piccy-draw ((frame piccy) stream)
;; this is somewhat complexified by the way url trees work --
;; because the nodes don't (necessarily) know their names, we have
;; to do this slightly nasty trick of using a cons of (name . node)
;; which we can make with MAP-UPT-NODE-CHILDREN. To kick it all off
;; you need to give the root node a fictitios name of "".
(let ((urp (piccy-urp frame))
(tree (piccy-tree frame)))
(format-graph-from-roots
(list (cons "" tree))
#'(lambda (name+node stream)
(let ((name (car name+node))
(node (cdr name+node)))
(if (upt-file-node-p node)
;; somewhat hacky.
(let ((val (upt-node-value node)))
(typecase val
(page-attributes
(with-output-as-presentation (stream val 'page-attributes)
(if (funcall urp val tree)
(with-drawing-options (stream :ink +red+)
(format stream "~A" name))
(format stream "~A" name))))
(t (with-drawing-options (stream :ink +yellow+)
(format stream "~A?" name)))))
(format stream "~A/" name))))
#'(lambda (name+node)
(let ((node (cdr name+node)))
(if (upt-file-node-p node)
'()
(let ((children '()))
(map-upt-node-children
#'(lambda (name node)
(push (cons name node) children))
node)
children))))
:move-cursor nil
:stream stream)))
(defmethod piccy-describe ((frame piccy) stream)
(let ((o (piccy-described-object frame)))
(typecase o
(page-attributes
(funcall (piccy-df frame) o (piccy-tree frame) stream))
(t
(with-text-style (stream '(:sans-serif :italic nil))
(format stream "(Select a file node)"))))))
(define-piccy-command set-described-page-attributes ((object 'page-attributes))
;; Describe a page attributes object (simply stiuff it in the slot,
;; redisplay will do the rest).
(with-application-frame (piccy)
(setf (piccy-described-object piccy) object)))
(define-presentation-to-command-translator set-described-page-attributes
(page-attributes set-described-page-attributes piccy
:gesture :select
:documentation "Describe this object")
(object)
(list object))
;;; This is not really any use, yet, but it's KOOL!
;;;
#+(and Unix Allegro)
(progn
(define-piccy-command send-page-to-netscape ((object 'page-attributes))
;; do what it says. This assumes you have a netscape running and
;; will *only* work locally.
(let ((pathname (urlpath->path-name (page-attributes-urlpath object))))
(clim-sys:make-process
#'(lambda ()
(excl:run-shell-command (vector
"netscape" "netscape" "-remote"
(format nil "openURL(file:~A)" pathname))
:output "/dev/null"
:if-output-exists ':append
:error-output ':output))
:name "Netscape dispatcher")))
(define-presentation-to-command-translator send-page-to-netscape
(page-attributes send-page-to-netscape piccy
:gesture :describe ;somewhat inappropriate
:documentation "Send this page to netscape")
(object)
(list object))
)
(defun piccy-default-describer (pa tree stream)
;; Should given a PAGE-ATTRIBUTES object, will fall about otherwise
;; This is slightly more complex than people could probably write.
(flet ((present-link-as-page-attributes-maybe (urlpath stream)
(let ((val (urlpath-value-in-upt urlpath tree)))
(typecase val
(page-attributes
(with-output-as-presentation (stream val 'page-attributes)
(princ (urlpath->path-name urlpath) stream)))
(t
(with-drawing-options (stream :ink +red+)
(princ (urlpath->path-name urlpath) stream)))))))
(formatting-table (stream)
(formatting-row (stream)
(formatting-cell (stream :align-x :right)
(with-text-style (stream '(:sans-serif :italic nil))
(princ "File" stream)))
(formatting-cell (stream :align-x :left)
(princ (urlpath->path-name (page-attributes-urlpath pa)) stream)))
(formatting-row (stream)
(formatting-cell (stream :align-x :right)
(with-text-style (stream '(:sans-serif :italic nil))
(princ "Links" stream)))
(formatting-cell (stream :align-x :left)
(format-items (page-attributes-links pa)
:stream stream
:n-columns 1
:printer #'present-link-as-page-attributes-maybe))))))
(defun draw-urlpath-tree (&key (tree *urlpath-tree*)
unresolved-pointer-predicate
describer-function)
;;+++export
"Draw a picture of a URLPATH tree.
TREE is something maed by MAKE-UPT.
UNRESOLVED-POINTER-PREDICATE, if given, takes a PAGE-ATTRIBUTES
object and a tree (TREE in fact) and should return T is there are
unresolved pointers. There is a default which works.
DESCRIBER-FUNCTION, if given, takes a PAGE-ATTRIBUTES object, a
tree, and a stream, and should print some useful information on
the stream. The default does a fairly comprehensive job,
including some CLIM stuff to make the links be clickable.
Pages with dangling links are painted red.
Clicking left on a page name calls the describer function on it.
On Unix, clicking middle will send the page to netscape -- this will
only work if the pages are visible in the local filesystem!"
(clim-sys:make-process
#'(lambda ()
(run-frame-top-level
(make-application-frame
'piccy
:tree tree
:unresolved-pointer-predicate unresolved-pointer-predicate
:describer-function describer-function)))
:name "URL Tree"))