84 lines
2.3 KiB
Plaintext
84 lines
2.3 KiB
Plaintext
#!/usr/local/bin/newlisp
|
|
;;
|
|
;; drag-demo.lsp - demonstrate dragging of objects with the mouse
|
|
;;
|
|
|
|
;;;; initialization
|
|
(set-locale "C")
|
|
(load (append (env "NEWLISPDIR") "/guiserver.lsp"))
|
|
|
|
(gs:init)
|
|
;(gs:set-trace true)
|
|
|
|
;;;; describe the GUI
|
|
(gs:frame 'DragDemo 100 100 600 500 "Drag demo")
|
|
;(gs:set-resizable 'DragDemo nil)
|
|
(gs:canvas 'MyCanvas)
|
|
(gs:set-background 'MyCanvas gs:white)
|
|
(gs:add-to 'DragDemo 'MyCanvas)
|
|
(gs:mouse-clicked 'MyCanvas 'mouse-clicked-action true)
|
|
(gs:mouse-pressed 'MyCanvas 'mouse-pressed-action true)
|
|
(gs:mouse-released 'MyCanvas 'mouse-released-action true)
|
|
(gs:mouse-dragged 'MyCanvas 'mouse-dragged-action)
|
|
|
|
;(gs:set-scale 0.5 0.5) ; only for testing, dragging would fail
|
|
|
|
(gs:set-font 'MyCanvas "Lucida Sans Oblique" 18 "plain")
|
|
(gs:draw-text 'T "Drag objects with the mouse, click right for popup menu" 20 250 gs:darkGray)
|
|
(gs:fill-circle 'C 100 100 50 gs:red)
|
|
(gs:fill-circle 'C 60 60 30 gs:black)
|
|
(gs:fill-circle 'C 140 60 30 gs:black)
|
|
(gs:fill-circle 'C 100 110 8 gs:yellow)
|
|
|
|
|
|
(gs:draw-polygon 'P '(300 200 400 50 500 200) gs:blue)
|
|
|
|
(gs:draw-image 'I "/local/newLISP128.png" 300 300 128 128)
|
|
|
|
(gs:menu-popup 'EditMenuPopup "Edit")
|
|
(gs:menu-item 'EditCut 'gs:no-action "Cut")
|
|
(gs:menu-item 'EditCopy 'gs:no-action "Copy")
|
|
(gs:menu-item 'EditPaste 'gs:no-action "Paste")
|
|
(gs:disable 'EditCut 'EditCopy 'EditPaste)
|
|
(gs:add-to 'EditMenuPopup 'EditCut 'EditCopy 'EditPaste)
|
|
|
|
; comment out to test reorder
|
|
;(gs:reorder-tags '(I P C T))
|
|
|
|
(gs:set-visible 'DragDemo true)
|
|
|
|
;(gs:update)
|
|
|
|
;; actions
|
|
(set 'mouse-down-tags '())
|
|
|
|
(define (mouse-clicked-action x y button cnt modifiers tags)
|
|
(gs:set-text 'DragDemo (string x ":" y " " button " " cnt " " tags))
|
|
(if (or (= 3 button) (= modifiers 18)) ; check for ctrl-button1-click on Mac
|
|
(gs:show-popup 'EditMenuPopup 'MyCanvas x y))
|
|
)
|
|
|
|
(define (mouse-pressed-action x y button modifiers tags)
|
|
(gs:set-text 'DragDemo (string x ":" y " " button " " modifiers " " tags))
|
|
(set 'mouse-down-tags tags)
|
|
(set 'mouse-old-x x)
|
|
(set 'mouse-old-y y)
|
|
)
|
|
|
|
(define (mouse-released-action x y button modifiers tags)
|
|
(gs:set-text 'DragDemo (string x ":" y " " button " " modifiers " " tags))
|
|
(set 'mouse-down-tags '())
|
|
)
|
|
|
|
(define (mouse-dragged-action x y)
|
|
(dolist (t mouse-down-tags)
|
|
(gs:move-tag t (- x mouse-old-x) (- y mouse-old-y)))
|
|
(set 'mouse-old-x x)
|
|
(set 'mouse-old-y y)
|
|
)
|
|
|
|
(gs:listen)
|
|
|
|
;; eof
|
|
|