guiserver/image-demo.lsp

   1 #!/usr/bin/newlisp
   2 ;;
   3 ;; image-demo.lsp - demonstrate images rotating and zooming
   4 ;; and the mouse-wheel rotating an object
   5
   6 ;;;; initialization
   7 (set-locale "C")
   8 (load (append (env "NEWLISPDIR") "/guiserver.lsp"))
   9
  10 (gs:init)
  11
  12 ;;;; describe the GUI
  13 (gs:frame 'ImageDemo  100 100 600 600 "Image demo")
  14 (gs:set-border-layout 'ImageDemo)
  15 ;(gs:set-resizable 'ImageDemo nil)
  16 (gs:canvas 'MyCanvas)
  17 (gs:set-background 'MyCanvas gs:white)
  18 (gs:panel 'Select)
  19 (gs:radio-button 'ZoomButton 'zoom-action "zoom")
  20 (gs:radio-button 'TurnButton 'turn-action "turn")
  21 (gs:set-selected 'TurnButton true)
  22 (set 'turn-flag true)
  23 (gs:add-to 'Select 'ZoomButton 'TurnButton)
  24 (gs:add-to 'ImageDemo 'MyCanvas "center" 'Select "south")
  25 (gs:mouse-wheel 'MyCanvas 'mouse-wheel-action)
  26
  27 ;(gs:set-scale 0.5 0.5) ; only for testing
  28
  29 (gs:set-font 'MyCanvas "Lucida Sans Oblique" 14 "plain")
  30 (gs:draw-text 'T "turn mouse wheel to turn or zoom image" 20 50 gs:darkGray)
  31 (gs:draw-image 'S "/local/newLISP128.png" 320 20 32 50)
  32 (gs:draw-image 'S "/local/newLISP128.png" 380 30 50 32)
  33
  34 (gs:draw-image 'I "/local/newLISP128.png" -64 -64)
  35 (gs:translate-tag 'I 300 300)
  36
  37 (gs:set-visible 'ImageDemo true)
  38
  39 ;; actions
  40
  41 (define (zoom-action id flag)
  42         (gs:set-selected 'TurnButton (not flag))
  43         (set 'turn-flag (not flag))
  44 )
  45
  46 (define (turn-action id flag)
  47         (gs:set-selected 'ZoomButton (not flag))
  48         (set 'turn-flag flag)
  49 )
  50
  51
  52 (define (mouse-wheel-action x y wheel)
  53         (if turn-flag
  54                 (gs:rotate-tag 'I wheel 0 0)
  55                 (if (< wheel 0)
  56                         (gs:scale-tag 'I 0.9 0.9)
  57                         (gs:scale-tag 'I 1.1 1.1)
  58                 )
  59         )
  60 )
  61
  62
  63 (gs:listen)
  64
  65 ;; eof
  66