newLISP で GUI する。。。または、gs:shear-tag を使ってみる（その２）

　前回の、guiserver の２Dグラフィックス関数 gs:shear-tag の動作例は、如何だったでしょうか？
　前回のスクリプトでは、表示されたウィンドウの大きさは変更できませんでした。
　それは、

(gs:set-resizable 'Frame nil)

　で、変更を禁止していたからです。guiserver アプリケーションのデフォルトは、サイズ変更可能なので、禁止する場合に、上記コードが必要になります。
　さて、今回は、サイズ変更可能にして、もう少し、gs:shear-tag の動作を見てみます。

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 
; define sub-routine
(define (center-point width height)
  (setq X-pos (/ width 2) Y-pos (/ height 2) Radius (/ (if (< width height) width height) 2)))
(define (draw-tag)
    (gs:draw-circle 'C X-pos Y-pos Radius gs:blue)
    (gs:draw-rect 'C (- X-pos Radius) (- Y-pos Radius) (* 2 Radius) (* 2 Radius)))
; define handler
(setq canvas-Size 400)
(center-point 400 400)
(setq shearX 0.0 shearY 0.0) 
(define (slider-action id value)
  (let (axis ((parse id) -1))
    (case axis 
      ("X-factor" (setq shearX (div (- value 50) 50 )))
      ("Y-factor" (setq shearY (div (- 50 value) 50))))
    (gs:delete-tag 'C)
    (draw-tag)
    (gs:shear-tag 'C shearX shearY)
    (gs:set-text 'Frame (string "(gs:shear-tag 'C " shearX " , " shearY " )"))))
(define (resize-action id width height)
  (let (cLst (gs:get-bounds 'OutputArea))
(println cLst)
    (center-point (cLst 2) (cLst 3)))
    (gs:delete-tag 'C)
    (draw-tag)
    (gs:shear-tag 'C shearX shearY)
)
; initialization
(gs:init)
(define FPosX 100)
(define FPosY 50)
(define FWidth canvas-Size)
(define FHeight canvas-Size)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "Frame")
(gs:set-text 'Frame (string "(gs:shear-tag 'C " shearX " , " shearY " )"))
(gs:set-border-layout 'Frame)
(gs:panel 'XPanel)
(gs:set-flow-layout 'XPanel "left")
(gs:panel 'YPanel)
;(gs:set-flow-layout 'YPanel "center")
(gs:slider 'X-factor 'slider-action "horizontal" 0 100 50)
(gs:slider 'Y-factor 'slider-action "vertical"   0 100 50)
(gs:canvas 'OutputArea)
(gs:set-background 'OutputArea gs:white)
; mount all on frame
(gs:add-to 'XPanel 'X-factor) 
(gs:add-to 'YPanel 'Y-factor) 
(gs:add-to 'XPanel 'X-factor) 
(gs:add-to 'YPanel 'Y-factor) 
(gs:add-to 'Frame 'XPanel "south" 'YPanel "east" 'OutputArea "center")
(gs:window-resized 'Frame 'resize-action)
(gs:set-visible 'Frame true)
(let (cLst (gs:get-bounds 'OutputArea))
  (gs:set-size 'Frame (+ canvas-Size (- canvas-Size (cLst 2))) (+ canvas-Size (- canvas-Size (cLst 3))))
)
; main routine
(gs:listen)
(exit)

　このスクリプトを実行し、ウィンドウを横に広げ、横のスライダを動かすと、

　こんな感じの変形も可能です。縦でも同様に変形します。
　こちらの変形の方が、この関数の一般的な使い方なのかも。
　私には、gs:shear-tag という関数名から、思い浮かばないですが、、、

　以上、如何でしょうか？

newLISP で GUI する。。。または、gs:shear-tag を使ってみる

　guiserver の２Dグラフィックス関数に gs:shear-tag というのがあります。
マニュアルには、説明がないので、日本語訳では、

gs:shear-tag
syntax: (gs:shear-tag sym-tag float-x float-y [boolean-repaint])
parameter: sym-tag – The tag group to shear.
parameter: float-x – The X shearing factor.
parameter: float-y – The Y shearing factor.
parameter: boolean-repaint – An optional flag to indicate if repainting is required (default is true).

（訳注：sym-tag で指定された 2Dグラフィックス・オブジェクトをハサミで潰すように変形します。）

　と、訳注を付けています。
　といっても、わかり辛いので、サンプルを書いてみました

; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp")) 
; define handler
(setq canvas-Size 400)
(setq X-pos (/ canvas-Size 2) Y-pos X-pos Radius (/ (* X-pos 9) 10))
(setq shearX 0.0 shearY 0.0) 
(define (slider-action id value)
  (let (axis ((parse id) -1))
    (case axis 
      ("X-factor" (setq shearX (div value 100)))
      ("Y-factor" (setq shearY (div (- 100 value) 100))))
    (gs:delete-tag 'C)
    (gs:draw-circle 'C X-pos Y-pos Radius gs:blue)
    (gs:draw-rect 'C 0 0 canvas-Size canvas-Size)
    (gs:shear-tag 'C shearX shearY)
    (gs:set-text 'Frame (string "(gs:shear-tag 'C " shearX " , " shearY " )"))
))
; initialization
(gs:init)
(define FPosX 100)
(define FPosY 50)
(define FWidth canvas-Size)
(define FHeight canvas-Size)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "Frame")
(gs:set-text 'Frame (string "(gs:shear-tag 'C " shearX " , " shearY " )"))
(gs:set-border-layout 'Frame)
(gs:panel 'XPanel)
(gs:set-flow-layout 'XPanel "left")
(gs:panel 'YPanel)
;(gs:set-flow-layout 'YPanel "center")
(gs:slider 'X-factor 'slider-action "horizontal" 0 100 0)
(gs:slider 'Y-factor 'slider-action "vertical"   0 100 100)
(gs:canvas 'OutputArea)
(gs:set-background 'OutputArea gs:white)
; mount all on frame
(gs:add-to 'XPanel 'X-factor) 
(gs:add-to 'YPanel 'Y-factor) 
(gs:add-to 'XPanel 'X-factor) 
(gs:add-to 'YPanel 'Y-factor) 
(gs:add-to 'Frame 'XPanel "south" 'YPanel "east" 'OutputArea "center")
(gs:set-visible 'Frame true)
(let (cLst (gs:get-bounds 'OutputArea)
      fLst (gs:get-bounds 'Frame)
      )
  (gs:set-size 'Frame (+ (fLst 2) (- canvas-Size (cLst 2))) (+ (fLst 3) (- canvas-Size (cLst 3))))
  (gs:set-size 'Frame (+ canvas-Size (- canvas-Size (cLst 2))) (+ canvas-Size (- canvas-Size (cLst 3))))
  (gs:draw-circle 'C X-pos Y-pos Radius gs:blue)
  (gs:draw-rect 'C 0 0 canvas-Size canvas-Size)
)
(gs:set-resizable 'Frame nil)
; main routine
(gs:listen)
(exit)

　このスクリプトを実行すれば、

　そして、縦と横のスライダを動かすと、

　こんな感じに 2Dグラフィックス・オブジェクトが変形されます。
　これを “ハサミで潰すように変形” と表記したのですが、、、

　以上、如何でしょうか？