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)