;; -*-Mode: Scheme;-*-
;;
;; Copyright (C) 1995, 1996 Josh MacDonald <jmacd@CS.Berkeley.EDU>
;;
;; Permission to use, copy, and/or distribute this software and its
;; documentation for any purpose and without fee is hereby granted, provided
;; that both the above copyright notice and this permission notice appear in
;; all copies and derived works. Fees for distribution or use of this
;; software or derived works may only be charged with express written
;; permission of the copyright holder.
;; This software is provided ``as is'' without express or implied warranty.
;;
;; $Id: view-profiles.stk,v 1.1 2003/12/19 22:57:30 willchu Exp $
;; $ProjectHeader: stk ucb2.29 Thu, 11 Sep 2003 14:07:59 -0700 hilfingr $
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROFILES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a profile is a list of 5 values,
;; 1: the width of the entire structure(x dir)
;; 2: the height of the entire structure(y dir)
;; 3: the displacement of the cell along the top of the area.
;; 4: the position of the car data, pair of x,y displacements
;; 5: the position of the cdr data, from the cell itself to the
;; next profile origin
;; xsize
;; <--------------------------->
;; xpos
;; <------------>
;; - - - - - ---*--- - - - - -
;; y | | | |
;; s | ------- |
;; i | / \ |
;; z | / \ |
;; e | / \ |
;; | carpos cdrpos |
;;
;; * is the coordinates returned by (coords-of cell)
(unless (provided? "view-profiles")
(define (xsize prof)
(list-ref prof 0)) ; x displacement of a profile
(define (ysize prof)
(list-ref prof 1)) ; y displacement of a profile
(define (xpos prof)
(list-ref prof 2)) ; amount which cell is displaced
; in x direction, it will always
; be 0 in the y direction.
(define (carpos prof)
(list-ref prof 3))
(define (cdrpos prof)
(list-ref prof 4))
(define ZERO-PROFILE (list 0 0 0 (list 0 0) (list 0 0)))
(define (set-scale! new)
(set! SCALE new))
;; Setting coordinates
(define CELL_X 0)
(define CELL_Y 0)
(define CAR_OFFSET 0)
(define CDR_OFFSET 0)
(define CDRP_OFFSET 0)
(define CARP_OFFSET 0)
(define CARP_TOP_CORR 0)
(define CARP_SIDE_CORR 0)
(define CDRP_TOP_CORR 0)
(define CDRP_SIDE_CORR 0)
(define (set-cell-size! new)
(set! CELL_SIZE new)
(set! CELL_X (list CELL_SIZE 0)) ;; the basis
(set! CELL_Y (list 0 CELL_SIZE)) ;; vectors
(set! CAR_OFFSET (* -1 CELL_X)) ;; offset of the rectangles
(set! CDR_OFFSET (list 0 0)) ;; which draw each cell half
(set! CDRP_OFFSET ;; from origin to head of
(* 0.5 (list CELL_SIZE CELL_SIZE))) ;; the pointer arrows
(set! CARP_OFFSET
(+ (* -0.5 CELL_X) (* 0.5 CELL_Y)))
(set! CARP_TOP_CORR (* -1 CARP_OFFSET)) ;; undoes the offset at the
(set! CARP_SIDE_CORR (* -0.5 CELL_Y)) ;; pointer's destination
(set! CDRP_TOP_CORR (* -1 CDRP_OFFSET)) ;; these depend on which
(set! CDRP_SIDE_CORR (* -1.5 CELL_X))) ;; display-type the pointer is
(set-cell-size! CELL_SIZE)
;; add profiles
;; takes two profiles and boolean describing layout, and returns total
;; profile. #t indicates tree, #f indicates normal layout. This is the
;; main part of the algorithm which lays out cells each time view is
;; called, or for new objects drawn by set! or set-cxr!. It fits the
;; two profiles of the car and cdr of a cell together and returns the
;; profile which tells build-tree how far to separate the children from
;; their parent.
(define (add-profiles carprof cdrprof istree?)
(let ((DEFAULT_LENGTH (* 2 SCALE))
(DEFAULT_SPACING SCALE)
(carwidth (xsize carprof))
(carheight (ysize carprof))
(cdrwidth (xsize cdrprof))
(cdrheight (ysize cdrprof))
(caroffset (xpos carprof))
(cdroffset (xpos cdrprof)))
(if istree?
(let ((position (max DEFAULT_LENGTH carwidth)))
(list (+ DEFAULT_SPACING
(max (* 2 DEFAULT_LENGTH) (+ carwidth cdrwidth)))
(+ DEFAULT_LENGTH (max carheight cdrheight))
(+ position (1/2 DEFAULT_SPACING))
(list (- caroffset position) DEFAULT_LENGTH)
(list (max cdroffset DEFAULT_LENGTH) DEFAULT_LENGTH)))
(let ((offsetcar? (and (>= (- carwidth caroffset) (* DEFAULT_LENGTH 2))
(<= DEFAULT_LENGTH cdrheight))))
(list (+ DEFAULT_LENGTH DEFAULT_SPACING cdrwidth caroffset)
(if offsetcar?
(+ carheight cdrheight)
(max cdrheight (+ DEFAULT_LENGTH carheight)))
caroffset
(list 0 (if offsetcar?
cdrheight
DEFAULT_LENGTH))
(list (+ DEFAULT_LENGTH DEFAULT_SPACING cdroffset) 0))))))
;; Build tree takes a toplevel to draw new cells on, an object to draw, and
;; the predicate which describes how to draw them. It returns either #f
;; if no new cells were created or the root cell which corresponds to the
;; object being drawn. It will be at coordinates (0 0) when returned, so
;; whatever calls build-tree must place the cell itself.
;; These are here so it will work when envdraw is not loaded.
(define (false-proc . args) #f)
(define frame-object? false-proc)
(define compound-procedure? false-proc)
(define procedure-object? false-proc)
(define view-continuation? false-proc)
(define special-form? false-proc)
(define (maybe-set-precise-position o)
(if (slot-bound? o 'sentinel)
(set-precise-position o)))
;; This is used by view-placement.stk to place new trees near old ones,
;; it is initialized #f each time build-tree is called.
(define *view-last-previous* #f)
(define (build-tree toplev scheme-obj treepred)
(let ((root #f)
(canvas (canvas-of toplev))
(col (color-of toplev))
(ht (table-of toplev)))
(set! *view-last-previous* #f)
(define (update-root obj)
(set! root obj)
(set! update-root (lambda (x) #f)))
(define (objectify scheme-obj)
(cond ((null? scheme-obj)
(let ((it (make <null-object>
:parent canvas
:coords '(0 0))))
(update-root it)
it))
((not (pair? scheme-obj))
(let ((it (make <viewed-object>
:parent canvas
:tl toplev
:coords '(0 0)
:obj (format #f "~S" scheme-obj))))
(hash-table-put! ht it it)
(update-root it)
it))
((compound-procedure? scheme-obj)
(list (procedure-object scheme-obj)))
((or (view-continuation? scheme-obj)
(special-form? scheme-obj))
(let ((it (make <viewed-object>
:parent canvas
:tl toplev
:coords '(0 0)
:obj (format #f "~A" (viewed-rep scheme-obj)))))
(hash-table-put! ht it it)
(update-root it)
it))
((let ((search (hash-table-get ht scheme-obj #f)))
(if search
(begin
(if (slot-ref search 'gc-flag)
(un-gc search ht))
(if (not *view-last-previous*)
(set! *view-last-previous* search))
(list search))
#f)))
(else
(let* ((display-type (treepred scheme-obj))
(instance
;; this is a tweaked version of make, it gets vital slots filled and
;; recorded for its children to find before calling initialize this is
;; because the initialize requires knowing its children, thus the
;; initialize call is tree recursive. This also means that any tree node
;; which is encountered which has already been created, it will not have
;; been initialized yet, so these nodes which have already been created
;; will not have children when they construct a list of their childen.
(let ((it (allocate-instance <viewed-cell> '())))
(slot-set! it 'parent canvas)
(slot-set! it 'obj scheme-obj)
(slot-set! it 'chwidgets '())
(slot-set! it 'mywidgets '())
(slot-set! it 'Cid (gensym "vc"))
(slot-set! it 'profile ZERO-PROFILE)
(slot-set! it 'par-wid-fns '())
(slot-set! it 'lastx 0)
(slot-set! it 'lasty 0)
(slot-set! it 'ptrs2me '())
(slot-set! it 'pointers '())
(slot-set! it 'gc-flag #f)
(set-parent! it #f)
(hash-table-put! ht scheme-obj it)
(update-root it)
(initialize it
(append
(list :parent canvas
:coords '(0 0)
:color col
:tl toplev)
(let ((car-c (objectify (car scheme-obj))))
(cond ((null? car-c) '(:carchild () :cartype null))
((pair? car-c) (list :carchild (car car-c)
:cartype 'already-posted))
(else (list :carchild car-c :cartype 'car))))
(let ((cdr-c (objectify (cdr scheme-obj))))
(cond ((null? cdr-c) '(:cdrchild () :cdrtype null))
((pair? cdr-c) (list :cdrchild (car cdr-c)
:cdrtype 'already-posted))
(else (list :cdrchild cdr-c :cdrtype 'cdr))))))
it))
(car-c (carchild-of instance))
(cdr-c (cdrchild-of instance))
(pointers (pointers-of instance))
(car-p (cdr (assoc 'car pointers)))
(cdr-p (cdr (assoc 'cdr pointers)))
(instpro (add-profiles (if (or (null? car-p)
(already-viewed? car-p))
ZERO-PROFILE
(profile car-c))
(if (or (null? cdr-p)
(already-viewed? cdr-p))
ZERO-PROFILE
(profile cdr-c))
display-type)))
(slot-set! instance 'profile instpro)
(unless (or (null? car-p) (already-viewed? car-p))
(add-group-to-tmci-group instance car-c))
(unless (or (null? cdr-p) (already-viewed? cdr-p))
(add-group-to-tmci-group instance cdr-c))
(cond ((null-object? car-c)
(add-to-tmci-group instance (sentinel-of car-c))
(move (sentinel-of car-c) (- CELL_SIZE) CELL_SIZE))
(else (add-prev-motion-hook instance car-p)
(add-motion-hook car-c car-p)
(if (viewed-object? car-c)
(move-tmci car-c
(atom-offset display-type 'car)))
(if (already-viewed? car-p)
(begin (maybe-set-precise-position car-c)
(apply move-head car-p (coords-of car-c)))
(move-tmci car-c (carpos instpro)))))
(cond ((null-object? cdr-c)
(add-to-tmci-group instance (sentinel-of cdr-c))
(move (sentinel-of cdr-c) 0 CELL_SIZE))
(else (add-prev-motion-hook instance cdr-p)
(add-motion-hook cdr-c cdr-p)
(if (viewed-object? cdr-c)
(move-tmci cdr-c
(atom-offset display-type 'cdr)))
(if (already-viewed? cdr-p)
(begin (maybe-set-precise-position cdr-c)
(apply move-head cdr-p (coords-of cdr-c)))
(move-tmci cdr-c (cdrpos instpro)))))
instance))))
;; set the positions properly (this is a time when exact positions
;; are needed, otherwise relative changes are all that is needed)
(for-each (lambda (x) (set-precise-position (cdr x)))
(hash-table->list ht))
(objectify scheme-obj)
root))
(provide "view-profiles")
)