;
;  matrix-frame.stklos  = group <matrix-square> objects into rows or columns
;
(require "Tk-classes")
(require "Canvas")
(require "balloon")
(require "matrix-square")

(define (create-matrix-squares fr m rc ind)
	(cond ((equal? rc 'row) (create-row-squares fr m ind 0))
	      (#t 		(create-col-squares fr m ind 0))))

(define (create-row-squares fr m ind ind2)
    (let*((cols (matrix-cols m))
	  (l (cond ((= ind2 cols) '())
	      (#t (cons (make <matrix-square> 
			:matrix m 
			:rownum ind 
			:colnum ind2
			:color "blue"
			:foreground "green"
			:relief "flat" :width 3
			:parent fr)
		     (create-row-squares fr m ind (+ ind2 1)))))))
	l))

(define (create-col-squares fr m ind ind2)
    (let*((rows (matrix-rows m))
	  (l (cond ((= ind2 rows) '())
	      (#t (cons (make <matrix-square> 
			:matrix m 
			:rownum ind2
			:colnum ind
			:color "blue"
			:foreground "green"
			:relief "flat" :width 3
			:parent fr)
		     (create-col-squares fr m ind (+ ind2 1)))))))
	l))

(define-class <matrix-frame> (<Frame>)
  ((square-list		:accessor square-list)
   (matrix		:accessor matrix :init-keyword :matrix)
   (index		:accessor index :init-keyword :index)
   (row-or-col		:accessor row-or-col :init-keyword :row-or-col)
))

(define-method initialize ((self <matrix-frame>) initargs)
  (next-method)
  (let* ((m         (get-keyword :matrix initargs ""))
         (rc        (get-keyword :row-or-col initargs ""))
         (ind       (get-keyword :index initargs "")))
    (slot-set! self 'matrix m)
    (slot-set! self 'square-list (create-matrix-squares self m rc ind))
    (apply pack (append (slot-ref self 'square-list) '(:side "left")))
  )
)

(define-generic matrix-frame?)
(define-method matrix-frame? ((v <matrix-frame>)) #t)
(define-method matrix-frame? ((v <top>)) #f)

(define-generic show-matrix)
(define-method show-matrix ((m <matrix<double>>))
	(let ((mv (make <matrix-frame> :matrix m)))
		(reset-graphics mv) mv))

(define (get-square fm j)
	(list-ref (slot-ref fm 'square-list) j))

(provide "matrix-frame")
