126 lines
4 KiB
Plaintext
126 lines
4 KiB
Plaintext
#!/usr/local/bin/newlisp
|
|
;;
|
|
;; shapes-demo.lsp - demonstrate different lines, outlines and shapes
|
|
;; v.1.0
|
|
|
|
;;;; initialization
|
|
(set-locale "C")
|
|
(load (append (env "NEWLISPDIR") "/guiserver.lsp"))
|
|
|
|
;; subroutines for random shapes
|
|
|
|
(define (random-draw-line)
|
|
(gs:draw-line 'L (rand 640) (rand 640) (rand 640) (rand 640) (list (random) (random) (random))))
|
|
|
|
(define (random-draw-rect)
|
|
(gs:draw-rect 'R (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-fill-rect)
|
|
(gs:fill-rect 'R (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-draw-round-rect)
|
|
(gs:draw-round-rect 'R (rand 640) (rand 640) (rand 100) (rand 100)
|
|
(rand 40) (rand 40) (list (random) (random) (random))))
|
|
|
|
(define (random-fill-round-rect)
|
|
(gs:fill-round-rect 'R (rand 640) (rand 640) (rand 100) (rand 100)
|
|
(rand 40) (rand 40) (list (random) (random) (random))))
|
|
|
|
(define (random-draw-circle)
|
|
(gs:draw-circle 'C (rand 640) (rand 640) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-fill-circle)
|
|
(gs:fill-circle 'C (rand 640) (rand 640) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-draw-ellipse)
|
|
(gs:draw-ellipse 'E (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-fill-ellipse)
|
|
(gs:fill-ellipse 'E (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
|
|
|
|
(define (random-draw-arc)
|
|
(gs:draw-arc 'A (rand 640) (rand 640) (rand 100) (rand 100) (rand 360) (rand 360) (list (random) (random) (random))))
|
|
|
|
(define (random-fill-arc)
|
|
(gs:fill-arc 'A (rand 640) (rand 640) (rand 100) (rand 100) (rand 360) (rand 360) (list (random) (random) (random))))
|
|
|
|
(gs:init)
|
|
;(gs:set-trace true)
|
|
|
|
;;;; describe the GUI
|
|
(gs:frame 'ShapesDemo 100 100 640 640 "Random lines, rectangles, circles, ellipses and arcs Demo")
|
|
(gs:set-border-layout 'ShapesDemo)
|
|
(gs:canvas 'MyCanvas 'ShapesDemo)
|
|
(gs:panel 'Selection)
|
|
(gs:label 'HelpText "show or hide shapes:")
|
|
(gs:check-box 'LineSelect 'select-action "lines")
|
|
(gs:check-box 'RectangleSelect 'select-action "rectangles")
|
|
(gs:check-box 'CircleSelect 'select-action "circles")
|
|
(gs:check-box 'EllipseSelect 'select-action "ellipse")
|
|
(gs:check-box 'ArcSelect 'select-action "arcs")
|
|
(gs:set-selected 'LineSelect true 'RectangleSelect true 'CircleSelect true 'EllipseSelect true 'ArcSelect true)
|
|
(gs:add-to 'Selection 'HelpText 'LineSelect 'RectangleSelect 'CircleSelect 'EllipseSelect 'ArcSelect)
|
|
(gs:add-to 'ShapesDemo 'MyCanvas "center" 'Selection "south")
|
|
(gs:set-background 'MyCanvas gs:white)
|
|
|
|
; default color if not specified in shape or text
|
|
(gs:set-paint gs:darkGray)
|
|
|
|
;(gs:set-translation 100 100) ;only for test, will shift everything
|
|
;(gs:set-scale 0.5 0.5) ; only for testing scrinks or zooms
|
|
;(gs:set-rotation 10) ; only for testing tilts by 10 degree
|
|
|
|
(set 'N 20)
|
|
|
|
(set 'N-shapes (* N 11))
|
|
|
|
(set 'start (time-of-day))
|
|
(dotimes (i N)
|
|
(random-draw-line)
|
|
(random-draw-rect)
|
|
(random-fill-rect)
|
|
(random-draw-round-rect)
|
|
(random-fill-round-rect)
|
|
(random-draw-circle)
|
|
(random-fill-circle)
|
|
(random-draw-ellipse)
|
|
(random-fill-ellipse)
|
|
(random-draw-arc)
|
|
(random-fill-arc)
|
|
)
|
|
|
|
(println N-shapes " shapes " (div (- (time-of-day) start) N-shapes) "ms per shape")
|
|
|
|
(gs:set-font 'MyCanvas "Lucida Sans Regular" 40 "italic")
|
|
(gs:draw-text 'T "Random" 60 100)
|
|
(gs:set-font 'MyCanvas "Monospaced" 40 "plain")
|
|
(gs:draw-text 'T "Shapes and Outlines" 60 160 gs:green -15)
|
|
;(gs:draw-text 'T "Third text line" 60 220) ; only for testing
|
|
|
|
(gs:set-visible 'ShapesDemo true)
|
|
|
|
;; action handler
|
|
|
|
(define (select-action id flag)
|
|
(let (tag (case id
|
|
("MAIN:LineSelect" 'L)
|
|
("MAIN:RectangleSelect" 'R)
|
|
("MAIN:CircleSelect" 'C)
|
|
("MAIN:EllipseSelect" 'E)
|
|
("MAIN:ArcSelect" 'A)))
|
|
(if flag
|
|
(gs:show-tag tag)
|
|
(gs:hide-tag tag))
|
|
)
|
|
)
|
|
|
|
(gs:add-to 'Selection 'HelpText 'LineSelect 'RectangleSelect 'CircleSelect 'EllipseSelect 'ArcSelect)
|
|
;;;; listen for incoming action requests and dispatch
|
|
|
|
;(gs:export "shapes.png") ; just for testing
|
|
|
|
(gs:listen)
|
|
|
|
;; eof
|
|
|