ADDED attic/vg.scm
Index: attic/vg.scm
==================================================================
--- /dev/null
+++ attic/vg.scm
@@ -0,0 +1,674 @@
+;;
+;; Copyright 2016 Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use typed-records srfi-1)
+
+(declare (unit vg))
+(use canvas-draw iup)
+(import canvas-draw-iup)
+
+(include "vg_records.scm")
+
+;;======================================================================
+;; IDEA
+;;
+;; make it possible to instantiate a vg drawing inside a vg drawing
+;;
+;;======================================================================
+
+;; ;; structs
+;; ;;
+;; (defstruct vg:lib comps)
+;; (defstruct vg:comp objs name file)
+;; ;; extents caches extents calculated on draw
+;; ;; proc is called on draw and takes the obj itself as a parameter
+;; ;; attrib is an alist of parameters
+;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
+;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
+;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache)
+;; ;; 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 scalex: 1
+ scaley: 1
+ xoff: 0
+ yoff: 0
+ libs: (make-hash-table)
+ insts: (make-hash-table)
+ cache: '()))
+
+;;======================================================================
+;; scaling and offsets
+;;======================================================================
+
+(define-inline (vg:scale-offset val s o)
+ (+ o (* val s)))
+ ;; (* (+ o val) s))
+
+;; apply scale and offset to a list of x y values
+;;
+(define (vg:scale-offset-xy lstxy sx sy ox oy)
+ (if (> (length lstxy) 1) ;; have at least one xy pair
+ (let loop ((x (car lstxy))
+ (y (cadr lstxy))
+ (tal (cddr lstxy))
+ (res '()))
+ (let ((newres (cons (vg:scale-offset y sy oy)
+ (cons (vg:scale-offset x sx ox)
+ res))))
+ (if (> (length tal) 1)
+ (loop (car tal)(cadr tal)(cddr tal) newres)
+ (reverse newres))))
+ '()))
+
+;; apply drawing offset and scaling to the points in lstxy
+;;
+(define (vg:drawing-apply-scale drawing lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:drawing-scalex drawing)
+ (vg:drawing-scaley drawing)
+ (vg:drawing-xoff drawing)
+ (vg:drawing-yoff drawing)))
+
+;; apply instance offset and scaling to the points in lstxy
+;;
+(define (vg:inst-apply-scale inst lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:inst-scalex inst)
+ (vg:inst-scaley inst)
+ (vg:inst-xoff inst)
+ (vg:inst-yoff inst)))
+
+;; apply both drawing and instance scaling to a list of xy points
+;;
+(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
+ (vg:drawing-apply-scale
+ drawing
+ (vg:inst-apply-scale inst lstxy)))
+
+;;======================================================================
+;; objects
+;;======================================================================
+
+;; (vg:inst-apply-scale
+;; inst
+;; (vg:drawing-apply-scale drawing lstxy)))
+
+;; make a rectangle obj
+;;
+(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
+
+;; make a rectangle obj
+;;
+(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
+
+;; make a text obj
+;;
+(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
+ (angle #f)(scale-with-zoom #f)(font #f)
+ (font-size #f))
+ (make-vg:obj type: 't pts: (list x1 y1) text: text
+ line-color: line-color fill-color: fill-color
+ angle: angle font: font extents: #f
+ attributes: (vg:make-attrib 'font-size font-size)))
+
+;; proc takes startnum and endnum and yields scalef, per-grad and unitname
+;;
+(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
+ (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
+
+;;======================================================================
+;; obj modifiers and queries
+;;======================================================================
+
+;; get extents, use knowledge of type ...
+;;
+(define (vg:obj-get-extents drawing obj)
+ (let ((type (vg:obj-type obj)))
+ (case type
+ ((l)(vg:rect-get-extents obj))
+ ((r)(vg:rect-get-extents obj))
+ ((t)(vg:draw-text drawing obj draw: #f))
+ (else #f))))
+
+(define (vg:rect-get-extents obj)
+ (vg:obj-pts obj)) ;; extents are just the points for a rectangle
+
+(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
+ (list
+ (- x1 borderx)
+ (- y1 bordery)
+ (+ x2 borderx)
+ (+ y2 bordery)))
+
+(define (vg:make-attrib . attrib-list)
+ #f)
+
+;;======================================================================
+;; components
+;;======================================================================
+
+;; add obj to comp
+;;
+(define (vg:add-objs-to-comp comp . objs)
+ (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
+
+(define (vg:add-obj-to-comp comp obj)
+ (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
+
+;; use the struct. leave this here to remind of this!
+;;
+;; (define (vg:comp-get-objs comp)
+;; (vg:comp-objs comp))
+
+;; 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 #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
+ (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
+ (hash-table-set! (vg:drawing-insts drawing) instname inst)))
+
+(define (vg:instance-move drawing instname newx newy)
+ (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
+ (vg:inst-xoff-set! inst newx)
+ (vg:inst-yoff-set! inst newy)))
+
+;; 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))
+
+(define (vg:get-extents-for-objs drawing objs)
+ (if (or (not objs)
+ (null? objs))
+ #f
+ (let loop ((hed (car objs))
+ (tal (cdr objs))
+ (extents (vg:obj-get-extents drawing (car objs))))
+ (let ((newextents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:obj-get-extents drawing hed))))
+ (if (null? tal)
+ extents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;; (let ((extents #f))
+;; (for-each
+;; (lambda (obj)
+;; (set! extents
+;; (vg:get-extents-for-two-rects
+;; extents
+;; (vg:obj-get-extents drawing obj))))
+;; objs)
+;; extents))
+
+;; given rectangles r1 and r2, return the box that bounds both
+;;
+(define (vg:get-extents-for-two-rects r1 r2)
+ (if (not r1)
+ r2
+ (if (not r2)
+ r1 ;; #f ;; no extents from #f #f
+ (list (min (car r1)(car r2)) ;; llx
+ (min (cadr r1)(cadr r2)) ;; lly
+ (max (caddr r1)(caddr r2)) ;; ulx
+ (max (cadddr r1)(cadddr r2)))))) ;; uly
+
+(define (vg:components-get-extents drawing . comps)
+ (if (null? comps)
+ #f
+ (let loop ((hed (car comps))
+ (tal (cdr comps))
+ (extents #f))
+ (let* ((objs (vg:comp-objs hed))
+ (newextents (if extents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:get-extents-for-objs drawing objs))
+ (vg:get-extents-for-objs drawing objs))))
+ (if (null? tal)
+ newextents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;;======================================================================
+;; libraries
+;;======================================================================
+
+;; register lib with drawing
+
+;;
+(define (vg:add-lib drawing libname lib)
+ (hash-table-set! (vg:drawing-libs drawing) libname lib))
+
+(define (vg:get-lib drawing libname)
+ (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
+
+(define (vg:get/create-lib drawing libname)
+ (let ((lib (vg:get-lib drawing libname)))
+ (if lib
+ lib
+ (let ((newlib (vg:lib-new)))
+ (vg:add-lib drawing libname newlib)
+ newlib))))
+
+;;======================================================================
+;; map objects given offset, scale and mirror, resulting obj is displayed
+;;======================================================================
+
+;; dispatch the drawing of obj off to the correct drawing routine
+;;
+(define (vg:map-obj drawing inst obj)
+ (case (vg:obj-type obj)
+ ((l)(vg:map-line drawing inst obj))
+ ((r)(vg:map-rect drawing inst obj))
+ ((t)(vg:map-text drawing inst obj))
+ ((x)(vg:map-xaxis drawing inst obj))
+ (else #f)))
+
+;; given a drawing and a inst map a rectangle to it screen coordinates
+;;
+(define (vg:map-rect drawing inst obj)
+ (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
+ 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 (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-line drawing inst obj)
+ (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a text to it screen coordinates
+;;
+(define (vg:map-text drawing inst obj)
+ (let ((res (make-vg:obj type: 't
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)
+ angle: (vg:obj-angle obj)
+ attrib: (vg:obj-attrib obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-xaxis drawing inst obj)
+ (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;;======================================================================
+;; instances
+;;======================================================================
+
+(define (vg:instances-get-extents drawing . instance-names)
+ (let ((xtnt-lst (vg:draw drawing #f)))
+ (if (null? xtnt-lst)
+ #f
+ (let loop ((extents (car xtnt-lst))
+ (tal (cdr xtnt-lst))
+ (llx #f)
+ (lly #f)
+ (ulx #f)
+ (uly #f))
+ (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
+ (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
+ (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
+ (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
+ (if (null? tal)
+ (list llx lly ulx uly)
+ (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
+
+(define (vg:lib-get-component lib instname)
+ (hash-table-ref/default (vg:lib-comps lib) instname #f))
+
+;;======================================================================
+;; color
+;;======================================================================
+
+(define (vg:rgb->number r g b #!key (a 0))
+ (bitwise-ior
+ (arithmetic-shift a 24)
+ (arithmetic-shift r 16)
+ (arithmetic-shift g 8)
+ b))
+
+;; Obsolete function
+;;
+(define (vg:generate-color)
+ (vg:rgb->number (pseudo-random-integer 255)
+ (pseudo-random-integer 255)
+ (pseudo-random-integer 255)))
+
+;; Need to return a string of random iup-color for graph
+;;
+(define (vg:generate-color-rgb)
+ (conc (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255))))
+
+(define (vg:iup-color->number iup-color)
+ (apply vg:rgb->number (map string->number (string-split iup-color))))
+
+;;======================================================================
+;; graphing
+;;======================================================================
+
+(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
+ (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
+ #f))
+
+;;======================================================================
+;; Unravel and draw the objects
+;;======================================================================
+
+;; with get-extents = #t return the extents
+;; with draw = #f don't actually draw the object
+;;
+(define (vg:draw-obj drawing obj #!key (draw #t))
+ ;; (print "obj type: " (vg:obj-type obj))
+ (case (vg:obj-type obj)
+ ((l)(vg:draw-line drawing obj draw: draw))
+ ((r)(vg:draw-rect drawing obj draw: draw))
+ ((t)(vg:draw-text drawing obj draw: draw))))
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-rect drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ (if fill-color
+ (begin
+ (canvas-foreground-set! cnv fill-color)
+ (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-rectangle! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax)))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts ;; no text
+ (if (and text-xmax text-ymax) ;; have text
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-line drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color))
+ ;; (if fill-color
+ ;; (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx lly ulx uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-xaxis drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ #;(if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-text drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (llx (car pts))
+ (lly (cadr pts)))
+ (if draw
+ (let* ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv))
+ (prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv llx lly text)
+ ;; NOTE: we do not set the font back!!
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
+ (append pts pts))
+ (append pts pts))))
+
+(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
+ (let* ((libname (vg:inst-libname inst))
+ (compname (vg:inst-compname inst))
+ (comp (vg:get-component drawing libname compname))
+ (objs (vg:comp-objs comp)))
+ ;; (print "comp: " comp)
+ (if (null? objs)
+ prev-extents
+ (let loop ((obj (car objs))
+ (tal (cdr objs))
+ (res prev-extents))
+ (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
+ (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
+
+(define (vg:draw drawing draw-mode . instnames)
+ (let* ((insts (vg:drawing-insts drawing))
+ (all-inst-names (hash-table-keys insts))
+ (master-list (if (null? instnames)
+ all-inst-names
+ instnames)))
+ (if (null? master-list)
+ '()
+ (let loop ((instname (car master-list))
+ (tal (cdr master-list))
+ (res '()))
+ (let* ((inst (hash-table-ref/default insts instname #f))
+ (newres (if inst
+ (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -51,10 +51,11 @@
nice-path
process:cmd-run->list
runconfig:read
runconfigs-get
safe-setenv
+ setenv
configf:eval-string-in-environment
)
(import scheme
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -41,14 +41,18 @@
(declare (uses rmtmod))
(declare (uses subrunmod))
(declare (uses tree))
(declare (uses vgmod))
(declare (uses testsmod))
+(declare (uses tasksmod))
;; (declare (uses dashboard-guimonitor))
;; (declare (uses dashboard-main))
+(module dashboard
+ *
+
(import (prefix iup iup:))
(import canvas-draw)
(import canvas-draw-iup)
(import ducttape-lib
@@ -63,10 +67,11 @@
regex regex-case srfi-69
typed-records
sparse-vectors
format
srfi-4
+ srfi-14
)
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
@@ -92,11 +97,13 @@
vgmod
dcommon
tree
dashboard-context-menu
dashboard-tests
- testsmod)
+ testsmod
+ tasksmod
+ )
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2017
@@ -409,11 +416,12 @@
(keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
(runs (make-sparse-vector)) ;; id => runrec
(runsbynum (make-vector 100 #f)) ;; vector num => runrec
(targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
(tests (make-hash-table)) ;; test[/itempath] => list of test rec
-
+ (path-run-ids (make-hash-table)) ;; path => run-id (this is a guess based on code reference)
+
;; run sql filters
(targ-sql-filt "%")
(runname-sql-filt "%")
(run-state-sql-filt "%")
(run-status-sql-filt "%")
@@ -485,11 +493,11 @@
status ;; test status
)
;; default is to NOT set the cell if the column and row names are not pre-existing
;;
-(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
+#;(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
(let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set))
(row-num (dcommon:runsdat-get-row-num dat testname itempath force-set)))
(if (and row-num col-num)
(let ((tdat (dboard:testdat
id: test-id
@@ -1693,11 +1701,11 @@
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
- (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
+ (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f)
#f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
@@ -3174,11 +3182,11 @@
(begin
(debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
#f)))))
(if (and dbpth (file-readable? dbpth))
(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
db)
#f)))
;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
@@ -3689,10 +3697,13 @@
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th2)
(thread-join! th2)))))
+)
+
+(import dashboard)
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
Index: task_records.scm
==================================================================
--- task_records.scm
+++ task_records.scm
@@ -15,30 +15,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
-(define (make-tasks:task)(make-vector 11))
-(define-inline (tasks:task-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:task-get-action vec) (vector-ref vec 1))
-(define-inline (tasks:task-get-owner vec) (vector-ref vec 2))
-(define-inline (tasks:task-get-state vec) (vector-ref vec 3))
-(define-inline (tasks:task-get-target vec) (vector-ref vec 4))
-(define-inline (tasks:task-get-name vec) (vector-ref vec 5))
-(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6))
-(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7))
-(define-inline (tasks:task-get-params vec) (vector-ref vec 8))
-(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9))
-(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10))
-
-(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val))
-
-
-;; make-vector-record tasks monitor id pid start_time last_update hostname username
-(define (make-tasks:monitor)(make-vector 5))
-(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1))
-(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2))
-(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3))
-(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4))
-(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5))
Index: tasksmod.scm
==================================================================
--- tasksmod.scm
+++ tasksmod.scm
@@ -90,11 +90,35 @@
;; (declare (uses common))
;; (declare (uses pgdb))
;; (import pgdb) ;; pgdb is a module
-(include "task_records.scm")
+;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
+(define (make-tasks:task)(make-vector 11))
+(define (tasks:task-get-id vec) (vector-ref vec 0))
+(define (tasks:task-get-action vec) (vector-ref vec 1))
+(define (tasks:task-get-owner vec) (vector-ref vec 2))
+(define (tasks:task-get-state vec) (vector-ref vec 3))
+(define (tasks:task-get-target vec) (vector-ref vec 4))
+(define (tasks:task-get-name vec) (vector-ref vec 5))
+(define (tasks:task-get-testpatt vec) (vector-ref vec 6))
+(define (tasks:task-get-keylock vec) (vector-ref vec 7))
+(define (tasks:task-get-params vec) (vector-ref vec 8))
+(define (tasks:task-get-creation_time vec) (vector-ref vec 9))
+(define (tasks:task-get-execution_time vec) (vector-ref vec 10))
+
+(define (tasks:task-set-state! vec val)(vector-set! vec 3 val))
+
+
+;; make-vector-record tasks monitor id pid start_time last_update hostname username
+(define (make-tasks:monitor)(make-vector 5))
+(define (tasks:monitor-get-id vec) (vector-ref vec 0))
+(define (tasks:monitor-get-pid vec) (vector-ref vec 1))
+(define (tasks:monitor-get-start_time vec) (vector-ref vec 2))
+(define (tasks:monitor-get-last_update vec) (vector-ref vec 3))
+(define (tasks:monitor-get-hostname vec) (vector-ref vec 4))
+(define (tasks:monitor-get-username vec) (vector-ref vec 5))
;; (include "db_records.scm")
;;======================================================================
;; Tasks db
;;======================================================================
DELETED vg.scm
Index: vg.scm
==================================================================
--- vg.scm
+++ /dev/null
@@ -1,674 +0,0 @@
-;;
-;; Copyright 2016 Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use typed-records srfi-1)
-
-(declare (unit vg))
-(use canvas-draw iup)
-(import canvas-draw-iup)
-
-(include "vg_records.scm")
-
-;;======================================================================
-;; IDEA
-;;
-;; make it possible to instantiate a vg drawing inside a vg drawing
-;;
-;;======================================================================
-
-;; ;; structs
-;; ;;
-;; (defstruct vg:lib comps)
-;; (defstruct vg:comp objs name file)
-;; ;; extents caches extents calculated on draw
-;; ;; proc is called on draw and takes the obj itself as a parameter
-;; ;; attrib is an alist of parameters
-;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
-;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
-;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache)
-;; ;; 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 scalex: 1
- scaley: 1
- xoff: 0
- yoff: 0
- libs: (make-hash-table)
- insts: (make-hash-table)
- cache: '()))
-
-;;======================================================================
-;; scaling and offsets
-;;======================================================================
-
-(define-inline (vg:scale-offset val s o)
- (+ o (* val s)))
- ;; (* (+ o val) s))
-
-;; apply scale and offset to a list of x y values
-;;
-(define (vg:scale-offset-xy lstxy sx sy ox oy)
- (if (> (length lstxy) 1) ;; have at least one xy pair
- (let loop ((x (car lstxy))
- (y (cadr lstxy))
- (tal (cddr lstxy))
- (res '()))
- (let ((newres (cons (vg:scale-offset y sy oy)
- (cons (vg:scale-offset x sx ox)
- res))))
- (if (> (length tal) 1)
- (loop (car tal)(cadr tal)(cddr tal) newres)
- (reverse newres))))
- '()))
-
-;; apply drawing offset and scaling to the points in lstxy
-;;
-(define (vg:drawing-apply-scale drawing lstxy)
- (vg:scale-offset-xy
- lstxy
- (vg:drawing-scalex drawing)
- (vg:drawing-scaley drawing)
- (vg:drawing-xoff drawing)
- (vg:drawing-yoff drawing)))
-
-;; apply instance offset and scaling to the points in lstxy
-;;
-(define (vg:inst-apply-scale inst lstxy)
- (vg:scale-offset-xy
- lstxy
- (vg:inst-scalex inst)
- (vg:inst-scaley inst)
- (vg:inst-xoff inst)
- (vg:inst-yoff inst)))
-
-;; apply both drawing and instance scaling to a list of xy points
-;;
-(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
- (vg:drawing-apply-scale
- drawing
- (vg:inst-apply-scale inst lstxy)))
-
-;;======================================================================
-;; objects
-;;======================================================================
-
-;; (vg:inst-apply-scale
-;; inst
-;; (vg:drawing-apply-scale drawing lstxy)))
-
-;; make a rectangle obj
-;;
-(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
- (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
-
-;; make a rectangle obj
-;;
-(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
- (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
-
-;; make a text obj
-;;
-(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
- (angle #f)(scale-with-zoom #f)(font #f)
- (font-size #f))
- (make-vg:obj type: 't pts: (list x1 y1) text: text
- line-color: line-color fill-color: fill-color
- angle: angle font: font extents: #f
- attributes: (vg:make-attrib 'font-size font-size)))
-
-;; proc takes startnum and endnum and yields scalef, per-grad and unitname
-;;
-(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
- (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
-
-;;======================================================================
-;; obj modifiers and queries
-;;======================================================================
-
-;; get extents, use knowledge of type ...
-;;
-(define (vg:obj-get-extents drawing obj)
- (let ((type (vg:obj-type obj)))
- (case type
- ((l)(vg:rect-get-extents obj))
- ((r)(vg:rect-get-extents obj))
- ((t)(vg:draw-text drawing obj draw: #f))
- (else #f))))
-
-(define (vg:rect-get-extents obj)
- (vg:obj-pts obj)) ;; extents are just the points for a rectangle
-
-(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
- (list
- (- x1 borderx)
- (- y1 bordery)
- (+ x2 borderx)
- (+ y2 bordery)))
-
-(define (vg:make-attrib . attrib-list)
- #f)
-
-;;======================================================================
-;; components
-;;======================================================================
-
-;; add obj to comp
-;;
-(define (vg:add-objs-to-comp comp . objs)
- (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
-
-(define (vg:add-obj-to-comp comp obj)
- (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
-
-;; use the struct. leave this here to remind of this!
-;;
-;; (define (vg:comp-get-objs comp)
-;; (vg:comp-objs comp))
-
-;; 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 #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
- (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
- (hash-table-set! (vg:drawing-insts drawing) instname inst)))
-
-(define (vg:instance-move drawing instname newx newy)
- (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
- (vg:inst-xoff-set! inst newx)
- (vg:inst-yoff-set! inst newy)))
-
-;; 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))
-
-(define (vg:get-extents-for-objs drawing objs)
- (if (or (not objs)
- (null? objs))
- #f
- (let loop ((hed (car objs))
- (tal (cdr objs))
- (extents (vg:obj-get-extents drawing (car objs))))
- (let ((newextents
- (vg:get-extents-for-two-rects
- extents
- (vg:obj-get-extents drawing hed))))
- (if (null? tal)
- extents
- (loop (car tal)(cdr tal) newextents))))))
-
-;; (let ((extents #f))
-;; (for-each
-;; (lambda (obj)
-;; (set! extents
-;; (vg:get-extents-for-two-rects
-;; extents
-;; (vg:obj-get-extents drawing obj))))
-;; objs)
-;; extents))
-
-;; given rectangles r1 and r2, return the box that bounds both
-;;
-(define (vg:get-extents-for-two-rects r1 r2)
- (if (not r1)
- r2
- (if (not r2)
- r1 ;; #f ;; no extents from #f #f
- (list (min (car r1)(car r2)) ;; llx
- (min (cadr r1)(cadr r2)) ;; lly
- (max (caddr r1)(caddr r2)) ;; ulx
- (max (cadddr r1)(cadddr r2)))))) ;; uly
-
-(define (vg:components-get-extents drawing . comps)
- (if (null? comps)
- #f
- (let loop ((hed (car comps))
- (tal (cdr comps))
- (extents #f))
- (let* ((objs (vg:comp-objs hed))
- (newextents (if extents
- (vg:get-extents-for-two-rects
- extents
- (vg:get-extents-for-objs drawing objs))
- (vg:get-extents-for-objs drawing objs))))
- (if (null? tal)
- newextents
- (loop (car tal)(cdr tal) newextents))))))
-
-;;======================================================================
-;; libraries
-;;======================================================================
-
-;; register lib with drawing
-
-;;
-(define (vg:add-lib drawing libname lib)
- (hash-table-set! (vg:drawing-libs drawing) libname lib))
-
-(define (vg:get-lib drawing libname)
- (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
-
-(define (vg:get/create-lib drawing libname)
- (let ((lib (vg:get-lib drawing libname)))
- (if lib
- lib
- (let ((newlib (vg:lib-new)))
- (vg:add-lib drawing libname newlib)
- newlib))))
-
-;;======================================================================
-;; map objects given offset, scale and mirror, resulting obj is displayed
-;;======================================================================
-
-;; dispatch the drawing of obj off to the correct drawing routine
-;;
-(define (vg:map-obj drawing inst obj)
- (case (vg:obj-type obj)
- ((l)(vg:map-line drawing inst obj))
- ((r)(vg:map-rect drawing inst obj))
- ((t)(vg:map-text drawing inst obj))
- ((x)(vg:map-xaxis drawing inst obj))
- (else #f)))
-
-;; given a drawing and a inst map a rectangle to it screen coordinates
-;;
-(define (vg:map-rect drawing inst obj)
- (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
- 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 (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;; given a drawing and a inst map a line to it screen coordinates
-;;
-(define (vg:map-line drawing inst obj)
- (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;; given a drawing and a inst map a text to it screen coordinates
-;;
-(define (vg:map-text drawing inst obj)
- (let ((res (make-vg:obj type: 't
- fill-color: (vg:obj-fill-color obj)
- text: (vg:obj-text obj)
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)
- angle: (vg:obj-angle obj)
- attrib: (vg:obj-attrib obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
- res))
-
-;; given a drawing and a inst map a line to it screen coordinates
-;;
-(define (vg:map-xaxis drawing inst obj)
- (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;;======================================================================
-;; instances
-;;======================================================================
-
-(define (vg:instances-get-extents drawing . instance-names)
- (let ((xtnt-lst (vg:draw drawing #f)))
- (if (null? xtnt-lst)
- #f
- (let loop ((extents (car xtnt-lst))
- (tal (cdr xtnt-lst))
- (llx #f)
- (lly #f)
- (ulx #f)
- (uly #f))
- (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
- (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
- (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
- (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
- (if (null? tal)
- (list llx lly ulx uly)
- (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
-
-(define (vg:lib-get-component lib instname)
- (hash-table-ref/default (vg:lib-comps lib) instname #f))
-
-;;======================================================================
-;; color
-;;======================================================================
-
-(define (vg:rgb->number r g b #!key (a 0))
- (bitwise-ior
- (arithmetic-shift a 24)
- (arithmetic-shift r 16)
- (arithmetic-shift g 8)
- b))
-
-;; Obsolete function
-;;
-(define (vg:generate-color)
- (vg:rgb->number (pseudo-random-integer 255)
- (pseudo-random-integer 255)
- (pseudo-random-integer 255)))
-
-;; Need to return a string of random iup-color for graph
-;;
-(define (vg:generate-color-rgb)
- (conc (number->string (pseudo-random-integer 255)) " "
- (number->string (pseudo-random-integer 255)) " "
- (number->string (pseudo-random-integer 255))))
-
-(define (vg:iup-color->number iup-color)
- (apply vg:rgb->number (map string->number (string-split iup-color))))
-
-;;======================================================================
-;; graphing
-;;======================================================================
-
-(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
- (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
- #f))
-
-;;======================================================================
-;; Unravel and draw the objects
-;;======================================================================
-
-;; with get-extents = #t return the extents
-;; with draw = #f don't actually draw the object
-;;
-(define (vg:draw-obj drawing obj #!key (draw #t))
- ;; (print "obj type: " (vg:obj-type obj))
- (case (vg:obj-type obj)
- ((l)(vg:draw-line drawing obj draw: draw))
- ((r)(vg:draw-rect drawing obj draw: draw))
- ((t)(vg:draw-text drawing obj draw: draw))))
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-rect drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- (if fill-color
- (begin
- (canvas-foreground-set! cnv fill-color)
- (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color)
- (if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-rectangle! cnv llx ulx lly uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax)))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts ;; no text
- (if (and text-xmax text-ymax) ;; have text
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-line drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- ;; (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- ;; (if fill-color
- ;; (begin
- ;; (canvas-foreground-set! cnv fill-color)
- ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color))
- ;; (if fill-color
- ;; (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-line! cnv llx lly ulx uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts
- (if (and text-xmax text-ymax)
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-xaxis drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- ;; (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- ;; (if fill-color
- ;; (begin
- ;; (canvas-foreground-set! cnv fill-color)
- ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color)
- #;(if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-line! cnv llx ulx lly uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts
- (if (and text-xmax text-ymax)
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-text drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (llx (car pts))
- (lly (cadr pts)))
- (if draw
- (let* ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv))
- (prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if line-color
- (canvas-foreground-set! cnv line-color)
- (if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv llx lly text)
- ;; NOTE: we do not set the font back!!
- (canvas-foreground-set! cnv prev-foreground-color)))
- (if cnv
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
- (append pts pts))
- (append pts pts))))
-
-(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
- (let* ((libname (vg:inst-libname inst))
- (compname (vg:inst-compname inst))
- (comp (vg:get-component drawing libname compname))
- (objs (vg:comp-objs comp)))
- ;; (print "comp: " comp)
- (if (null? objs)
- prev-extents
- (let loop ((obj (car objs))
- (tal (cdr objs))
- (res prev-extents))
- (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
- (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))))))
-
-(define (vg:draw drawing draw-mode . instnames)
- (let* ((insts (vg:drawing-insts drawing))
- (all-inst-names (hash-table-keys insts))
- (master-list (if (null? instnames)
- all-inst-names
- instnames)))
- (if (null? master-list)
- '()
- (let loop ((instname (car master-list))
- (tal (cdr master-list))
- (res '()))
- (let* ((inst (hash-table-ref/default insts instname #f))
- (newres (if inst
- (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
- res)))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))))))
Index: vg_records.scm
==================================================================
--- vg_records.scm
+++ vg_records.scm
@@ -18,154 +18,7 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
(import simple-exceptions)
-(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
-(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
-(define (make-vg:lib #!key
- (comps #f)
- )
- (vector 'vg:lib comps))
-
-(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
-
-(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
-;; Generated using make-vector-record -safe vg comp objs name file
-
-(import simple-exceptions)
-(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
-(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
-(define (make-vg:comp #!key
- (objs #f)
- (name #f)
- (file #f)
- )
- (vector 'vg:comp objs name file))
-
-(define-inline (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
-(define-inline (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
-(define-inline (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
-
-(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
-(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
-(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
-;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
-
-(import simple-exceptions)
-(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
-(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
-(define (make-vg:obj #!key
- (type #f)
- (pts #f)
- (fill-color #f)
- (text #f)
- (line-color #f)
- (call-back #f)
- (angle #f)
- (font #f)
- (attrib #f)
- (extents #f)
- (proc #f)
- )
- (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc))
-
-(define-inline (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr))))
-(define-inline (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr))))
-(define-inline (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr))))
-(define-inline (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr))))
-(define-inline (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr))))
-(define-inline (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr))))
-(define-inline (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr))))
-(define-inline (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr))))
-(define-inline (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr))))
-(define-inline (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr))))
-(define-inline (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr))))
-
-(define-inline (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type))))
-(define-inline (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts))))
-(define-inline (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color))))
-(define-inline (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text))))
-(define-inline (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color))))
-(define-inline (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back))))
-(define-inline (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
-(define-inline (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
-(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
-(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
-(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
-;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
-
-(import simple-exceptions)
-(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
-(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
-(define (make-vg:inst #!key
- (libname #f)
- (compname #f)
- (theta #f)
- (xoff #f)
- (yoff #f)
- (scalex #f)
- (scaley #f)
- (mirrx #f)
- (mirry #f)
- (call-back #f)
- (cache #f)
- )
- (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache))
-
-(define-inline (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr))))
-(define-inline (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr))))
-(define-inline (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr))))
-(define-inline (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr))))
-(define-inline (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr))))
-(define-inline (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr))))
-(define-inline (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr))))
-(define-inline (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr))))
-(define-inline (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr))))
-(define-inline (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr))))
-(define-inline (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr))))
-
-(define-inline (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname))))
-(define-inline (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname))))
-(define-inline (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta))))
-(define-inline (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff))))
-(define-inline (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff))))
-(define-inline (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex))))
-(define-inline (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
-(define-inline (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
-(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
-(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
-(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
-;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
-
-(import simple-exceptions)
-(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
-(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
-(define (make-vg:drawing #!key
- (libs #f)
- (insts #f)
- (scalex #f)
- (scaley #f)
- (xoff #f)
- (yoff #f)
- (cnv #f)
- (cache #f)
- )
- (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache))
-
-(define-inline (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr))))
-(define-inline (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr))))
-(define-inline (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr))))
-(define-inline (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr))))
-(define-inline (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr))))
-(define-inline (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr))))
-(define-inline (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr))))
-(define-inline (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr))))
-
-(define-inline (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs))))
-(define-inline (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts))))
-(define-inline (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex))))
-(define-inline (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley))))
-(define-inline (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff))))
-(define-inline (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff))))
-(define-inline (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv))))
-(define-inline (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache))))
+
+;; moved to vgmod.scm
Index: vgmod.scm
==================================================================
--- vgmod.scm
+++ vgmod.scm
@@ -28,14 +28,166 @@
chicken.bitwise
chicken.string
chicken.random
)
-(import canvas-draw iup)
-(import typed-records srfi-1 srfi-69)
+ (import canvas-draw
+ iup
+ typed-records
+ srfi-1
+ srfi-69
+ simple-exceptions)
+
+(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
+(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
+(define (make-vg:lib #!key
+ (comps #f)
+ )
+ (vector 'vg:lib comps))
+
+(define (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
+
+(define (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
+;; Generated using make-vector-record -safe vg comp objs name file
+
+(import simple-exceptions)
+(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
+(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
+(define (make-vg:comp #!key
+ (objs #f)
+ (name #f)
+ (file #f)
+ )
+ (vector 'vg:comp objs name file))
+
+(define (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
+(define (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
+(define (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
+
+(define (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
+(define (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
+(define (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
+;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
+
+(import simple-exceptions)
+(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
+(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
+(define (make-vg:obj #!key
+ (type #f)
+ (pts #f)
+ (fill-color #f)
+ (text #f)
+ (line-color #f)
+ (call-back #f)
+ (angle #f)
+ (font #f)
+ (attrib #f)
+ (extents #f)
+ (proc #f)
+ )
+ (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc))
+
+(define (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr))))
+(define (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr))))
+(define (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr))))
+(define (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr))))
+(define (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr))))
+(define (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr))))
+(define (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr))))
+(define (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr))))
+(define (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr))))
+(define (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr))))
+(define (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr))))
+
+(define (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type))))
+(define (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts))))
+(define (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color))))
+(define (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text))))
+(define (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color))))
+(define (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back))))
+(define (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
+(define (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
+(define (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
+(define (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
+(define (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
+;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
+
+(import simple-exceptions)
+(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
+(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
+(define (make-vg:inst #!key
+ (libname #f)
+ (compname #f)
+ (theta #f)
+ (xoff #f)
+ (yoff #f)
+ (scalex #f)
+ (scaley #f)
+ (mirrx #f)
+ (mirry #f)
+ (call-back #f)
+ (cache #f)
+ )
+ (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache))
+
+(define (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr))))
+(define (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr))))
+(define (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr))))
+(define (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr))))
+(define (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr))))
+(define (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr))))
+(define (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr))))
+(define (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr))))
+(define (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr))))
+(define (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr))))
+(define (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr))))
+
+(define (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname))))
+(define (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname))))
+(define (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta))))
+(define (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff))))
+(define (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff))))
+(define (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex))))
+(define (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
+(define (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
+(define (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
+(define (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
+(define (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
+;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
+
+(import simple-exceptions)
+(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
+(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
+(define (make-vg:drawing #!key
+ (libs #f)
+ (insts #f)
+ (scalex #f)
+ (scaley #f)
+ (xoff #f)
+ (yoff #f)
+ (cnv #f)
+ (cache #f)
+ )
+ (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache))
+
+(define (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr))))
+(define (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr))))
+(define (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr))))
+(define (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr))))
+(define (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr))))
+(define (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr))))
+(define (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr))))
+(define (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr))))
-(include "vg_records.scm")
+(define (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs))))
+(define (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts))))
+(define (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex))))
+(define (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley))))
+(define (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff))))
+(define (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff))))
+(define (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv))))
+(define (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache))))
;; ;; structs
;; ;;
;; (defstruct vg:lib comps)
;; (defstruct vg:comp objs name file)