;---------------------------------------------------------------------------
; hollywood.stklos
;
; Here is an implementation of the hollywood squares game in Link.
; run Link and do the following:
;    STk> (load "hollywood.stklos")                 ; this file
;    STk> (init-hollywood)                          ; and play!
;---------------------------------------------------------------------------
(define *cells* '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2) (2 0) (2 1) (2 2)))

(define *one-third* (/ 1 3))
(define *two-thirds* (* *one-third* 2))

(define (which-cell vx vy gv)
	(let* ((third-of-x (/ (slot-ref gv 'xpixels) 3))
	       (third-of-y (/ (slot-ref gv 'ypixels) 3))
               (cell-col (inexact->exact (floor (/ vx third-of-x))))
               (cell-row (inexact->exact (floor (/ vy third-of-y)))))
	   (list cell-row cell-col)))

(define (gv-line gv wx1 wy1 wx2 wy2)
   (let ((gc (slot-ref gv 'graph-canvas)))
	(make <line> :parent gc 
                     :coords (append (world-to-view wx1 wy1 gv)
                                     (world-to-view wx2 wy2 gv)))))

(define (h-grid gv)
	(list (gv-line gv  *one-third* 0 *one-third* 1)
	      (gv-line gv  *two-thirds* 0 *two-thirds* 1)
	      (gv-line gv  0 *one-third* 1 *one-third*)
	      (gv-line gv  0 *two-thirds* 1 *two-thirds*)))

(define (lower-left cell-row cell-col)
	(list (* cell-col *one-third*) 
              (- *two-thirds* (* cell-row *one-third*))))

(define (upper-right cell-row cell-col)
	(list (+ (* cell-col *one-third*) *one-third*) 
              (+ (- *two-thirds* (* cell-row *one-third*)) *one-third*)))

(define (cell-to-view xylist cell-row cell-col)
	(let* ((ll (lower-left cell-row cell-col))
	       (ur (upper-right cell-row cell-col))
	       (llx (car ll))
	       (lly (cadr ll))
	       (urx (car ur))
	       (ury (cadr ur))
	       (x   (car xylist))
	       (y   (cadr xylist))
	       (sx  (- urx llx))
	       (sy  (- ury lly)))
           (list (+ (* x sx) llx)
                 (+ (* y sy) lly))))

(define (world-to-cell xylist cell-coords)
	(let* ((cell-row (car cell-coords))
	       (cell-col (cadr cell-coords))
	       (ll (lower-left cell-row cell-col))
	       (c-llx (car ll))
	       (c-lly (cadr ll))
	       (x   (car xylist))
	       (y   (cadr xylist)))
           (display (list (- x c-llx)
                          (- y c-lly)))
	   (newline)
           (list (/ (- x c-llx) *one-third*)
                 (/ (- y c-lly) *one-third*))))

(define (new-cell-vertex gv cell-row cell-col mx my)
        (let* ((wcrds (cell-to-view (list mx my) cell-row cell-col))
               (vcrds (world-to-view (car wcrds) (cadr wcrds) gv)))
	   (add-vertex-item! gv (car vcrds) (cadr vcrds))))

(define (add-vertex-all-cells! mx my gv)
	(new-cell-vertex gv 0 0 mx my)
	(new-cell-vertex gv 0 1 mx my)
	(new-cell-vertex gv 0 2 mx my)
	(new-cell-vertex gv 1 0 mx my)
	(new-cell-vertex gv 1 1 mx my)
	(new-cell-vertex gv 1 2 mx my)
	(new-cell-vertex gv 2 0 mx my)
	(new-cell-vertex gv 2 1 mx my)
	(new-cell-vertex gv 2 2 mx my)
        (hide-labels gv))

(define (peer-verts center-v peer-list vlist)
        (cond ((null? vlist) '())
              ((peer center-v (car vlist)) 
                  (cons (car vlist) (peer-verts center-v peer-list 
                                               (cdr vlist))))
	      (#t (peer-verts center-v peer-list (cdr vlist)))))

(define (peer-vertices center-v g)
        (peer-verts center-v '() (set-vertex->list (vertices g))))

(define (graph-with v)
	(slot-ref (hash-table-get *link:graph-view-table* (owner v)) 'graph))

(define (same-cell v1 v2)
	(let ((v1-rank (vertex-rank v1 (graph-with v1)))
	      (v2-rank (vertex-rank v2 (graph-with v2))))
           (equal? (modulo v1-rank 9) (modulo v2-rank 9))))

(define (same-row v1 v2)
	(let*((v1-modulus (modulo (vertex-rank v1 (graph-with v1)) 9))
	      (v2-modulus (modulo (vertex-rank v2 (graph-with v2)) 9))
              (row-div1 (quotient v1-modulus 3))
              (row-div2 (quotient v2-modulus 3)))
           (equal? row-div1 row-div2)))

(define (mod-diff v1 v2)
       (- (modulo (vertex-rank v2 (graph-with v2)) 9)
          (modulo (vertex-rank v1 (graph-with v2)) 9)))

(define (quot-diff v1 v2)
       (- (quotient (vertex-rank v2 (graph-with v2)) 3)
          (quotient (vertex-rank v1 (graph-with v2)) 3)))

(define (find-match-in-same-row m-diff v1 v-list)
	(cond ((null? v-list) #f)
              ((and (not (same-cell v1 (car v-list)))
		    (same-row    v1 (car v-list))
                    (equal? (modulo (mod-diff v1 (car v-list)) 3) 
			    (modulo m-diff 3))) (car v-list))
	      (#t (find-match-in-same-row m-diff v1 (cdr v-list)))))

(define (find-match-in-same-column q-diff v1 v-list)
	(cond ((null? v-list) #f)
              ((and (not (same-cell v1 (car v-list)))
                    (same-column v1 (car v-list))
                    (equal? (modulo (quot-diff v1 (car v-list)) 3) 
			    (modulo q-diff 3))) (car v-list))
	      (#t (find-match-in-same-column q-diff v1 (cdr v-list)))))

(define (adjacent-cells v1 v2)
	(if (or    (and (same-row v1 v2)
                        (= (abs (mod-diff v1 v2)) 1))
	           (and (same-column v1 v2)
                        (<= (abs (mod-diff v1 v2)) 3)))
            #t #f))

(define (add-edge-between-cells! v1 v2 gv)
	(let ((pv1 (peer-vertices v1 (graph gv)))
	      (pv2 (peer-vertices v2 (graph gv)))
              (mdiff (mod-diff v1 v2))
              (qdiff (quot-diff v1 v2))
              (sr (same-row v1 v2))
              (sc (same-row v1 v2)))
          (map (lambda (peer-of-v1)
                  (let*((row-peer-of-v2 
                             (find-match-in-same-row mdiff peer-of-v1 pv2))
                        (col-peer-of-v2 
                             (find-match-in-same-column qdiff peer-of-v1 pv2))
                        (peer-of-v2 (if sr row-peer-of-v2 col-peer-of-v2)))
                    (if (adjacent-cells peer-of-v1 peer-of-v2)
		          (add-edge-item! peer-of-v1 peer-of-v2 gv))))
               pv1)))

(define (same-column v1 v2)
	(let*((v1-modulus (modulo (vertex-rank v1 (graph-with v1)) 9))
	      (v2-modulus (modulo (vertex-rank v2 (graph-with v2)) 9))
              (col-mod1 (modulo v1-modulus 3))
              (col-mod2 (modulo v2-modulus 3)))
           (equal? col-mod1 col-mod2)))

(define (peer v1 v2)
	(let ((v1-rank (vertex-rank v1 (graph-with v1)))
	      (v2-rank (vertex-rank v2 (graph-with v2))))
	   (equal? (quotient v1-rank 9) (quotient v2-rank 9))))

(define-generic add-edge-all-cells!)
(define-method add-edge-all-cells! ((cv1 <vertex*>) (cv2 <vertex*>)
                                    (gv <graph-view>))
      (if (same-cell cv1 cv2)
        (map (lambda (v1 v2)  
                 (add-edge-item! v1 v2 gv))
             (peer-vertices cv1 (graph gv))
             (peer-vertices cv2 (graph gv)))
        (add-edge-between-cells! cv1 cv2 gv)) 
      (hide-labels gv))

(define-method add-edge-all-cells! ((sv <sequence<vertex*>>)
                                    (gv <graph-view>))
      (if (>= (size sv) 2)
		(add-edge-all-cells! (ref sv 0) (ref sv 1) gv)))

(define-generic remove-edge-all-cells!)
(define-method remove-edge-all-cells! ((cv1 <vertex*>) (cv2 <vertex*>)
                                    (gv <graph-view>))
      (if (same-cell cv1 cv2)
        (map (lambda (v1 v2)  
                 (remove-edge-item! (edge-item (is-edge v1 v2)) gv))
             (peer-vertices cv1 (graph gv))
             (peer-vertices cv2 (graph gv)))
        (remove-edge-between-cells! cv1 cv2 gv)) 
      (hide-labels gv))

(define-method remove-edge-all-cells! ((ei <edge-item>)
                                       (gv <graph-view>))
	(remove-edge-all-cells! (ref (vertices (edge ei)) 0)
	                        (ref (vertices (edge ei)) 1) gv))

(define (move-vertex-all-cells! cv mx my gv)
           (map (lambda (peer-v cell)
                  (let ((wcrds (cell-to-view (list mx my) 
                                             (car cell) (cadr cell))))
                     (move-vertex-kbd (vertex-item peer-v)
                                      (car wcrds) (cadr wcrds))))
	         (peer-vertices cv (graph gv))
                 *cells*))

(define (remove-vertex-all-cells! cv gv)
	(let ((peers (peer-vertices cv (graph gv))))
		(map (lambda (x)
                         (remove-vertex-item! (vertex-item x) gv))
                     peers)))

(define (link:select-item x vtag-table etag-table)
        ;;; allows duplicates (mult. segments in hyperedge)
        (let ((eg (hash-table-get etag-table (slot-ref x 'cid) #f)))
            (cond ((and eg (not(member "link:selected" (tags eg))))
                    (set! *link:selected-edge-items*
                                (cons eg *link:selected-edge-items*))
                    (map (lambda (s)
                           (add-tag s 'link:selected)
                           (set! (stipple s) 'gray50))
                                        (slot-ref eg 'seg-list)))))
       (let*((vg (hash-table-get vtag-table (slot-ref x 'cid) #f)))
             (cond ((and vg (not(member "link:selected" (tags vg))))
		(let* ((gv (graph-view vg))
		       (peer-items (cons vg (map vertex-item 
				   (peer-vertices (vertex vg)
					 (graph gv))))))
                        (set! *link:selected-vertex-items*
                             (append peer-items *link:selected-vertex-items*))
		        (map (lambda(vg) (add-tag vg 'link:selected))
				         peer-items)
			(map (lambda(vg) (slot-set! vg 'width 3))
				         peer-items)
			(map (lambda(vg) (set! (outline vg) 'black))
				         peer-items)))))
)

(define (source-vertex edge-item)
        (ref (edge-vertices (edge edge-item)) 0))

(define (sink-vertex edge-item)
        (ref (edge-vertices (edge edge-item)) 1))

(define (remove-edge-between-cells! v1 v2 gv)
	(let ((pv1 (peer-vertices v1 (graph gv)))
	      (pv2 (peer-vertices v2 (graph gv)))
              (mdiff (mod-diff v1 v2))
              (qdiff (quot-diff v1 v2))
              (sr (same-row v1 v2))
              (sc (same-row v1 v2)))
          (map (lambda (peer-of-v1)
                  (let*((row-peer-of-v2 
                             (find-match-in-same-row mdiff peer-of-v1 pv2))
                        (col-peer-of-v2 
                             (find-match-in-same-column qdiff peer-of-v1 pv2))
                        (peer-of-v2 (if sr row-peer-of-v2 col-peer-of-v2)))
		    (if (adjacent-cells peer-of-v1 peer-of-v2)
                      (remove-edge-item! 
			(edge-item (is-edge peer-of-v1 peer-of-v2)) gv))))
               pv1)))

(define (link:hollywood-shift-button-3-binding c ctab)
  (bind c "<Shift-Button-3>"
   (lambda (x y)
	)))
;
; resets vertex and edge creation to create peer verts, edges
;
(define (link:hollywood-button-3-binding c ctab)
  (bind c "<Button-3>"
   (lambda (x y)
        (set! *link:undirected-in-mixed* #f)
        (let*  ((items (find-items c 'withtag 'current))
                (gv (hash-table-get ctab c))
                (g  (slot-ref gv 'graph)))
          (cond ((null? items) 
                   (let ((mdl-crds (world-to-cell (view-to-world x y gv)
                                                   (which-cell x y gv))))
                      (add-vertex-all-cells! (car mdl-crds)(cadr mdl-crds)gv)))
                ((not (null? *link:new-edge-vertices*))
                        (let ((i (find-items c 'withtag 'drag)))
                                (for-each (lambda(x)
                                           (destroy x)) i))
                        (let* ((its (find-items c 'overlapping x y x y)))
                           (cond ((not (null? its))
                             (append! (slot-ref(link:find-vertex-in-list its)
                                                        'vertex)
                                       *link:new-edge-vertices*)
                             (add-edge-all-cells! *link:new-edge-vertices* gv)
                                        )))
                        (clear! *link:new-edge-vertices*))
                ((member "vertex" (tags (car items)))
                        (append! (slot-ref (car items) 'vertex)
                                                *link:new-edge-vertices*)
                        (make <oval>    :parent (slot-ref gv 'graph-canvas)
                                        :coords (list x y x y)
                                        :tags 'drag)
                        (make <line>    :parent (slot-ref gv 'graph-canvas)
                                        :coords (list x y x y)
                                        :tags 'drag)))))))
;
; resets the vertex movement to move peers
;
(define (stop-vertex-drag w x y)
         (let* ((gcanv (slot-ref w 'parent))
                (gv    (hash-table-get *link:canvas-table* gcanv))
                (vttab (slot-ref gv 'vertex-tag-table))
                (vg (hash-table-get vttab (cid w)))
                (crds (slot-ref vg 'coords))
                (mdl-crds (world-to-cell (view-to-world x y gv)
                                                   (which-cell x y gv))))
	   (move-vertex-all-cells! (vertex vg)(car mdl-crds)(cadr mdl-crds) gv)
           (update-edges vg (car crds) (cadr crds)
                                     (slot-ref vg 'vertex)
                                     (slot-ref gv 'vertex-table)
                                     (slot-ref gv 'edge-table)
                                     (incident-edges (slot-ref vg 'vertex))))
        (destroy *link:vertex-placeholder*))

;
; resets deletion to delete peers as well as original
;
(define (link:delete-selected gv)
        (map (lambda (eg) (remove-edge-all-cells! eg gv)) 
				*link:selected-edge-items*)
        (map (lambda (vg) (remove-vertex-all-cells! (vertex vg) gv))
                                *link:selected-vertex-items*)
        (set! *link:selected-vertex-items* '())
        (set! *link:selected-edge-items* '())
)



(define (init-hollywood)
    (define gv (make <graph-view> :graph (ubingraph) :layout 'custom))
    (slot-set! gv 'xpixels 500)
    (slot-set! gv 'ypixels 500)
    (define hg (h-grid gv))
    (define c (slot-ref gv 'graph-canvas))
    (define ctab *link:canvas-table*)
    (link:hollywood-button-3-binding c ctab) hg)