guiserver/stroke-demo.lsp

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