;; -*-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-pointers.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 $
;;

(require "simple-pointer")

(unless (provided? "view-pointers")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                            POINTERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <cell-pointer> (<simple-pointer>)
  ((curroff    :initform '(0 0))
   (spacing    :initform (random (inexact->exact (floor (/ CELL_SIZE 3)))))
   (type       :init-keyword :type) ;; car cdr or already-viewed
   (car-or-cdr :init-keyword :car-or-cdr))) ;; like type but always car or cdr

(define (already-viewed? pointer)
  (equal? (slot-ref pointer 'type) 'already-posted))

;; two types of motion hook

(define-method pointer-motion-hook((pointer <cell-pointer>))
  (lambda (already-moved dx dy)
    (unless (memq (parent-of pointer) already-moved)
      (cell-move-head pointer dx dy))))

(define-method prev-pointer-motion-hook((pointer <cell-pointer>))
  (lambda (already-moved dx dy)
    (unless (memq (slot-ref pointer 'child) already-moved)
      (cell-move-head pointer (- dx) (- dy)))))

(define (make-car-pointer canvas coords coordsto color)
  (make <line>
	:parent canvas
	:fill (asHex (darken-color color))
	:coords
	  (append (+ coords CARP_OFFSET) coordsto)
	:arrow "last"
	:width POINTER_WIDTH))

(define (make-cdr-pointer canvas coords coordsto color)
  (make <line>
	:parent canvas
	:fill (asHex (darken-color color))
	:coords
	  (append (+ coords CDRP_OFFSET) coordsto)
	:arrow "last"
	:width POINTER_WIDTH))

;; these two connect vobj and a new viewed-object

(define (add-car-pointer vobj newcar tl)
  (let ((nptr (make (cond ((viewed-cell? newcar) <cell-pointer>)
			  ((procedure-object? newcar) <cell-to-proc-pointer>)
			  (else <atom-pointer>))
		    :car-or-cdr 'car
		    :parent vobj
		    :child newcar
		    :type 'car))
	(pwid (make-car-pointer (canvas-of vobj)
				(coords-of vobj)
				(if (procedure-object? newcar)
				    (list PROCEDURE_DIAMETER 0)
				    '(0 0))
				(color-of tl))))
    (slot-set! nptr 'pwid pwid)
    (slot-prepend! vobj 'pointers (cons 'car nptr))
    (slot-prepend! newcar 'ptrs2me nptr)
    (add-to-tmci-group vobj pwid)
    (add-prev-motion-hook vobj nptr)
    (add-motion-hook newcar nptr)))

(define (add-cdr-pointer vobj newcdr tl)
  (let ((nptr (make (cond ((viewed-cell? newcdr) <cell-pointer>)
			  ((procedure-object? newcdr) <cell-to-proc-pointer>)
			  (else <atom-pointer>))
		    :car-or-cdr 'cdr
		    :parent vobj
		    :child newcdr
		    :type 'cdr))
	(pwid (make-cdr-pointer (canvas-of vobj)
				(coords-of vobj)
				(if (procedure-object? newcdr)
				    (list PROCEDURE_DIAMETER 0)
				    '(0 0))
				(color-of tl))))
    (slot-set! nptr 'pwid pwid)
    (slot-prepend! vobj 'pointers (cons 'cdr nptr))
    (slot-prepend! newcdr 'ptrs2me nptr)
    (add-to-tmci-group vobj pwid)
    (add-prev-motion-hook vobj nptr)
    (add-motion-hook newcdr nptr)))

;; pointer motion

;; this may look a lot more confusing than it perhaps is.  a pointer
;; has coordinates, a random offset, and a current offset.  the random
;; offset is thrown in to help disinguish several pointers which would
;; otherwise lie on top of each other.  the coordinates always consist
;; of some number of points, the first point is the tail and will never
;; change, only the head, which is the last coordinate, will ever change.
;; the head's coordinate is added with the previous offset to get the
;; position of the cell which it points too, from that it determines
;; a good geometry and determines a new offset, which will either include
;; the random offset, an offset to keep the pointer horizontal or vertical,
;; or no offset at all.

(define (cell-move-head pointer dx dy)
  (let* ((old-coords (coords-of pointer))
	 (tail (first-two old-coords))
	 (head (+ (list dx dy) (- (slot-ref pointer 'curroff))
		  (last-two old-coords)))
	 (new-coords (find-cell-pointer tail head
					(slot-ref pointer 'spacing)
					(slot-ref pointer 'car-or-cdr))))
    (slot-set! pointer 'curroff (- (last-two new-coords) head))
    (slot-set! pointer 'coords new-coords)))

(define (find-cell-pointer tail head randoff ptype)
  (let* ((dx (- (car tail) (car head)))
	 (dy (- (cadr tail) (cadr head)))
	 (adx (abs dx))
	 (ady (abs dy)))
    (cond ((and (>= adx CELL_SIZE)
		(>= ady CELL_SIZE))
	   (if (> dy 0)
	       (append tail (+ head CELL_Y))
	       (append tail head)))
	  ((<= adx CELL_SIZE)
	   (if (>= ady CELL_SIZE)
	       (let ((can-drop?
		      (or (and (equal? ptype 'car)
			       (>= dx (- CELL_SIZE))
			       (<= dx (* 1.5 CELL_SIZE)))
			  (and (equal? ptype 'cdr)
			       (>= dx (* -1.5 CELL_SIZE))
			       (<= dx CELL_SIZE)))))
		 (if can-drop?
		     (if (< dy 0)
			 (append tail (+ head (list dx 0)))
			 (append tail (+ head CELL_Y (list dx 0))))
		     (append tail (+ CELL_Y head))))
	       (let ((basis-y (list 0 (- CELL_SIZE)))
		     (basis-x (if (equal? ptype 'car)
				  (list (- CELL_SIZE) 0)
				  (list (+ CELL_SIZE) 0)))
		     (offset (if (equal? ptype 'car)
				 (list (- randoff) 0)
				 (list randoff 0))))
		 (append tail
			 (+ tail basis-x)
			 (+ tail basis-x basis-y)
			 (+ head (list 0 dy) basis-y offset)
			 (+ offset head)))))
	  (else (let ((basis-y (list 0 (- CELL_SIZE)))
		      (basis-x (list (if (> dx 0) CELL_SIZE (- CELL_SIZE)) 0))
		      (cut-corner? (or (and (equal? ptype 'car) (> dx 0))
				       (and (equal? ptype 'cdr) (< dx 0)))))
		  (cond (cut-corner?
			 (cond
			  ((and (<= ady CELL_SIZE) (>= dy 0))
			   (append tail (+ head basis-x (list 0 dy))))
			  (else
			   (append tail (+ head (list (- randoff) dy))
				   (+ (list (- randoff) 0) head)))))
			(else (append tail
				      (+ tail basis-y (list 0 (- randoff)))
				      (+ head (list 0 dy) basis-y
					 (list randoff (- randoff)))
				      (+ (list randoff 0) head)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                         ATOM POINTERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-class <atom-pointer> (<simple-pointer>)
  ((type       :allocation :virtual
	       :slot-set! (lambda (o w) #t)
	       :slot-ref (lambda (w) 'atom))
   (curroff    :initform '(0 0))))

(define-method pointer-motion-hook((pointer <atom-pointer>))
  (lambda (already-moved dx dy)
    (unless (memq (parent-of pointer) already-moved)
      (atom-move-head pointer dx dy))))

(define-method prev-pointer-motion-hook((pointer <atom-pointer>))
  (lambda (already-moved dx dy)
    (unless (memq (slot-ref pointer 'child) already-moved)
      (atom-move-head pointer (- dx) (- dy)))))

(define (atom-move-head pointer dx dy)
  (let* ((old-coords (coords-of pointer))
	 (tail (first-two old-coords))
	 (head (+ (list dx dy) (- (slot-ref pointer 'curroff))
		  (last-two old-coords)))
	 (new-coords (find-atom-pointer tail head)))
    (slot-set! pointer 'curroff (- (last-two new-coords) head))
    (slot-set! pointer 'coords new-coords)))

(define (find-atom-pointer tail head)
  (if (>= (y-coord head) (y-coord tail))
      (append tail head)
      (append tail (list (x-coord head) (+ 15 (y-coord head))))))

(provide "view-pointers")

)