guiserver/shapes-demo.lsp

   1 #!/usr/bin/newlisp
   2 ;;
   3 ;; shapes-demo.lsp - demonstrate different lines, outlines and shapes
   4
   5 ;;;; initialization
   6 (set-locale "C")
   7 (load (append (env "NEWLISPDIR") "/guiserver.lsp"))
   8
   9 ;; subroutines for random shapes
  10
  11 (define (random-draw-line)
  12         (gs:draw-line 'L (rand 640) (rand 640) (rand 640) (rand 640) (list (random) (random) (random))))
  13
  14 (define (random-draw-rect)
  15         (gs:draw-rect 'R (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
  16
  17 (define (random-fill-rect)
  18         (gs:fill-rect 'R (rand 640) (rand 640) (rand 100) (rand 100) (list (random) (random) (random))))
  19
  20 (define (random-draw-round-rect)
  21         (gs:draw-round-rect 'R (rand 640) (rand 640) (rand 100) (rand 100)
  22                         (rand 40) (rand 40) (list (random) (random) (random))))
  23
  24 (define (random-fill-round-rect)
  25         (gs:fill-round-rect 'R (rand 640) (rand 640) (rand 100) (rand 100)
  26                         (rand 40) (rand 40) (list (random) (random) (random))))
  27
  28 (define (random-draw-circle)
  29         (gs:draw-circle 'C (rand 640) (rand 640) (rand 100)  (list (random) (random) (random))))
  30
  31 (define (random-fill-circle)
  32         (gs:fill-circle 'C (rand 640) (rand 640) (rand 100)  (list (random) (random) (random))))
  33
  34 (define (random-draw-ellipse)
  35         (gs:draw-ellipse 'E (rand 640) (rand 640) (rand 100)  (rand 100) (list (random) (random) (random))))
  36
  37 (define (random-fill-ellipse)
  38         (gs:fill-ellipse 'E (rand 640) (rand 640) (rand 100)  (rand 100) (list (random) (random) (random))))
  39
  40 (define (random-draw-arc)
  41         (gs:draw-arc 'A (rand 640) (rand 640) (rand 100) (rand 100) (rand 360) (rand 360) (list (random) (random) (random))))
  42
  43 (define (random-fill-arc)
  44         (gs:fill-arc 'A (rand 640) (rand 640) (rand 100) (rand 100) (rand 360) (rand 360) (list (random) (random) (random))))
  45
  46 (gs:init)
  47 ;(gs:set-trace true)
  48
  49 ;;;; describe the GUI
  50 (gs:frame 'ShapesDemo 100 100 640 640 "Random lines, rectangles, circles, ellipses and arcs Demo")
  51 (gs:set-border-layout 'ShapesDemo)
  52 (gs:canvas 'MyCanvas 'ShapesDemo)
  53 (gs:panel 'Selection)
  54 (gs:label 'HelpText "show or hide shapes:")
  55 (gs:check-box 'LineSelect 'select-action "lines")
  56 (gs:check-box 'RectangleSelect 'select-action "rectangles")
  57 (gs:check-box 'CircleSelect 'select-action "circles")
  58 (gs:check-box 'EllipseSelect 'select-action "ellipse")
  59 (gs:check-box 'ArcSelect 'select-action "arcs")
  60 (gs:set-selected 'LineSelect true 'RectangleSelect true 'CircleSelect true 'EllipseSelect true 'ArcSelect true)
  61 (gs:add-to 'Selection 'HelpText 'LineSelect 'RectangleSelect 'CircleSelect 'EllipseSelect 'ArcSelect)
  62 (gs:add-to 'ShapesDemo 'MyCanvas "center" 'Selection "south")
  63 (gs:set-background 'MyCanvas gs:white)
  64
  65 ; default color if not specified in shape or text
  66 (gs:set-paint gs:darkGray)
  67
  68 ;(gs:set-translation 100 100) ;only for test, will shift everything
  69 ;(gs:set-scale 0.5 0.5) ; only for testing scrinks or zooms
  70 ;(gs:set-rotation 10) ; only for testing tilts by 10 degree
  71
  72
  73
  74 (println (time-of-day))
  75 (dotimes (i 20)
  76         (random-draw-line)
  77         (random-draw-rect)
  78         (random-fill-rect)
  79         (random-draw-round-rect)
  80         (random-fill-round-rect)
  81         (random-draw-circle)
  82         (random-fill-circle)
  83         (random-draw-ellipse)
  84         (random-fill-ellipse)
  85         (random-draw-arc)
  86         (random-fill-arc)
  87 )
  88 (println (time-of-day))
  89
  90 (gs:set-font 'MyCanvas "Lucida Sans Regular" 40 "italic")
  91 (gs:draw-text 'T "Random"  60 100)
  92 (gs:set-font 'MyCanvas "Monospaced" 40 "plain")
  93 (gs:draw-text 'T "Shapes and Outlines"  60 160 gs:green -15)
  94 ;(gs:draw-text 'T "Third text line"  60 220) ; only for testing
  95
  96 (gs:set-visible 'ShapesDemo true)
  97
  98 ;; action handler
  99
 100 (define (select-action id flag)
 101         (set 'tag (case id
 102                 ("MAIN:LineSelect" 'L)
 103                 ("MAIN:RectangleSelect" 'R)
 104                 ("MAIN:CircleSelect" 'C)
 105                 ("MAIN:EllipseSelect" 'E)
 106                 ("MAIN:ArcSelect" 'A))
 107         )
 108         (if flag
 109                 (gs:show-tag tag)
 110                 (gs:hide-tag tag)
 111         )
 112 )
 113
 114 (gs:add-to 'Selection 'HelpText 'LineSelect 'RectangleSelect 'CircleSelect 'EllipseSelect 'ArcSelect)
 115 ;;;; listen for incoming action requests and dispatch
 116
 117 ;(gs:export "shapes.png") ; just for testing
 118
 119 (gs:listen)
 120
 121 ;; eof
 122