Megatest

(use canvas-draw iup)
(import canvas-draw-iup)

(load "vg.scm")

(define d1 (vg:drawing-new))
(define l1 (vg:lib-new))
(define c1 (vg:comp-new))
(let ((r1 (vg:make-rect 10 10 100 80))
      (r2 (vg:make-rect 100 80 190 150)))
  (vg:add-objs-to-comp c1 r1 r2))

;; add the c1 component to lib l1 with name firstcomp
(vg:add-comp-to-lib l1 "firstcomp" c1)

;; add the l1 lib to drawing with name firstlib
(vg:add-lib d1 "firstlib" l1)

;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0
(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0 0)
(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200 0)

(define cnv #f)
(define the-cnv (canvas 
		 #:size "500x400"
		 #:expand "YES"
		 #:scrollbar "YES"
		 #:posx "0.5"
		 #:posy "0.5"
		 #:action (make-canvas-action
			   (lambda (c xadj yadj)
			     (set! cnv c)))))

(show
 (dialog
  (vbox
   the-cnv)))

(vg:drawing-cnv-set! d1 cnv)
(vg:draw d1)

;; (canvas-rectangle! cnv  10 100 10 80)

(main-loop)

;;
;; Copyright 2016  Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use defstruct)

(declare (unit vg))

;; structs
;;
(defstruct vg:lib     comps)
(defstruct vg:comp    objs name file)
(defstruct vg:obj     type pts fill-color text line-color call-back font)
(defstruct vg:inst    libname compname theta xoff yoff scale mirrx mirry call-back)
(defstruct vg:drawing libs insts cnv) ;; libs: hash of name->lib, insts: hash of instname->inst

;; inits
;;
(define (vg:comp-new)
  (make-vg:comp objs: '() name: #f file: #f))

(define (vg:lib-new)
  (make-vg:lib comps: (make-hash-table)))

(define (vg:drawing-new)
  (make-vg:drawing libs: (make-hash-table) insts: (make-hash-table)))

;; make a rectangle obj
;;
(define (vg:make-rect x1 y1 x2 y2 #!key (line-color #f)(fill-color #f))
  (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: #f line-color: line-color fill-color: fill-color))

;; add obj to comp
;;
(define (vg:add-objs-to-comp comp . objs)
  (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))

;; add comp to lib
;;
(define (vg:add-comp-to-lib lib compname comp)
  (hash-table-set! (vg:lib-comps lib) compname comp))

;; instanciate component in drawing
;;
(define (vg:instantiate drawing libname compname instname xoff yoff t #!key (scale 1)(mirrx #f)(mirry #f))
  (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: t scale: scale mirrx: mirrx mirry: mirry)) )
    (hash-table-set! (vg:drawing-insts drawing) instname inst)))

;; get component from drawing (look in apropriate lib) given libname and compname
(define (vg:get-component drawing libname compname)
  (let* ((lib  (hash-table-ref (vg:drawing-libs drawing) libname))
	 (inst (hash-table-ref (vg:lib-comps lib) compname)))
    inst))

;; register lib with drawing
;;
(define (vg:add-lib drawing libname lib)
  (hash-table-set! (vg:drawing-libs drawing) libname lib))

;;======================================================================
;; map objects given offset, scale and mirror
;;======================================================================

(define (vg:map-obj xoff yoff theta scale mirrx mirry obj)
  (case (vg:obj-type obj)
    ((r)(vg:map-rect xoff yoff theta scale mirrx mirry obj))
    (else #f)))

(define (vg:map-rect xoff yoff theta scale mirrx mirry obj)
  (let ((res (make-vg:obj type:       'r
			  fill-color: (vg:obj-fill-color obj)
			  text:       (vg:obj-text       obj)
			  line-color: (vg:obj-line-color obj)
			  font:       (vg:obj-font       obj)))
	(pts (vg:obj-pts obj)))
    (vg:obj-pts-set! res 
		     (list (+ xoff (car pts))
			   (+ yoff (cadr pts))
			   (+ xoff (caddr pts))
			   (+ yoff (cadddr pts))))
    res))

;;======================================================================
;; Unravel and draw the objects
;;======================================================================

(define (vg:draw-obj cnv obj)
  (print "obj type: " (vg:obj-type obj))
  (case (vg:obj-type obj)
    ((r)(vg:draw-rect cnv obj))))

(define (vg:draw-rect cnv obj)
  (let* ((pts (vg:obj-pts obj))
	 (llx (car pts))
	 (lly (cadr pts))
	 (urx (caddr pts))
	 (ury (cadddr pts)))
    (print "(canvas-rectangle! " cnv " " llx " " urx " " lly " " ury ")")
    (canvas-rectangle! cnv llx urx lly ury)
    ))

(define (vg:draw drawing)
  (let ((insts (vg:drawing-insts drawing))
	(cnv   (vg:drawing-cnv   drawing)))
    (for-each 
     (lambda (inst)
       (let* ((xoff     (vg:inst-xoff inst))
	      (yoff     (vg:inst-yoff inst))
	      (theta    (vg:inst-theta inst))
	      (scale    (vg:inst-scale inst))
	      (mirrx    (vg:inst-mirrx inst))
	      (mirry    (vg:inst-mirry inst))
	      (libname  (vg:inst-libname inst))
	      (compname (vg:inst-compname inst))
	      (comp     (vg:get-component drawing libname compname)))
	 (print "comp: " comp)
	 (for-each
	  (lambda (obj)
	    (print "obj: " obj)
	    (vg:draw-obj cnv (vg:map-obj xoff yoff theta scale mirrx mirry obj)))
	  (vg:comp-objs comp))))
    (hash-table-values insts))))