66 lines
1.6 KiB
Text
66 lines
1.6 KiB
Text
#!/usr/local/bin/newlisp
|
|
;;
|
|
;; rotationn-demo.lsp - demonstrate gs:rotate-tag, gs:translate-tag and gs:scale-tag
|
|
;; and the mouse-wheel rotating an object
|
|
|
|
;;;; initialization
|
|
(set-locale "C")
|
|
(load (append (env "NEWLISPDIR") "/guiserver.lsp"))
|
|
|
|
(gs:init)
|
|
;(gs:set-trace true)
|
|
|
|
;;;; describe the GUI
|
|
(gs:frame 'RotationDemo 100 100 600 600 "Image demo")
|
|
(gs:set-border-layout 'RotationDemo)
|
|
;(gs:set-resizable 'RotationDemo nil)
|
|
(gs:canvas 'MyCanvas)
|
|
(gs:set-background 'MyCanvas gs:white)
|
|
(gs:panel 'Select)
|
|
(gs:radio-button 'ZoomButton 'zoom-action "zoom")
|
|
(gs:radio-button 'TurnButton 'turn-action "turn")
|
|
(gs:set-selected 'TurnButton true)
|
|
(set 'turn-flag true)
|
|
(gs:add-to 'Select 'ZoomButton 'TurnButton)
|
|
(gs:add-to 'RotationDemo 'MyCanvas "center" 'Select "south")
|
|
(gs:mouse-wheel 'MyCanvas 'mouse-wheel-action)
|
|
|
|
;(gs:set-scale 0.5 0.5) ; only for testing
|
|
|
|
(gs:set-font 'MyCanvas "Lucida Sans Oblique" 14 "plain")
|
|
(gs:draw-text 'T "turn mouse wheel to turn or zoom image" 20 50 gs:darkGray)
|
|
(gs:fill-circle 'C 0 0 50 gs:red)
|
|
(gs:fill-circle 'C -40 -40 30 gs:black)
|
|
(gs:fill-circle 'C 40 -40 30 gs:black)
|
|
(gs:fill-circle 'C 0 10 8 gs:yellow)
|
|
(gs:translate-tag 'C 300 300)
|
|
|
|
(gs:set-visible 'RotationDemo true)
|
|
|
|
;; actions
|
|
|
|
(define (zoom-action id flag)
|
|
(gs:set-selected 'TurnButton (not flag))
|
|
(set 'turn-flag (not flag))
|
|
)
|
|
|
|
(define (turn-action id flag)
|
|
(gs:set-selected 'ZoomButton (not flag))
|
|
(set 'turn-flag flag)
|
|
)
|
|
|
|
(define (mouse-wheel-action x y wheel)
|
|
(if turn-flag
|
|
(gs:rotate-tag 'C wheel 0 0)
|
|
(if (< wheel 0)
|
|
(gs:scale-tag 'C 0.9 0.9)
|
|
(gs:scale-tag 'C 1.1 1.1)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(gs:listen)
|
|
|
|
;; eof
|
|
|