72 lines
1.6 KiB
Factor
72 lines
1.6 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: generic kernel lists math namespaces sdl ;
|
|
|
|
! A line.
|
|
TUPLE: line x y w h ;
|
|
|
|
M: line shape-x dup line-x dup rot line-w + min ;
|
|
M: line shape-y dup line-y dup rot line-h + min ;
|
|
M: line shape-w line-w abs 1 + ;
|
|
M: line shape-h line-h abs 1 + ;
|
|
|
|
: line-pos ( line -- #{ x y }# )
|
|
dup line-x x get + swap line-y y get + rect> ;
|
|
|
|
: line-dir ( line -- #{ w h }# ) dup line-w swap line-h rect> ;
|
|
|
|
: move-line-x ( x line -- )
|
|
[ line-w dupd - max ] keep set-line-x ;
|
|
|
|
: move-line-y ( y line -- )
|
|
[ line-h dupd - max ] keep set-line-y ;
|
|
|
|
M: line move-shape ( x y line -- )
|
|
tuck move-line-y move-line-x ;
|
|
|
|
: resize-line-w ( w line -- )
|
|
>r 1 - r>
|
|
dup line-w 0 >= [
|
|
set-line-w
|
|
] [
|
|
2dup
|
|
[ [ line-w + ] keep line-x + ] keep set-line-x
|
|
>r neg r> set-line-w
|
|
] ifte ;
|
|
|
|
: resize-line-h ( w line -- )
|
|
>r 1 - r>
|
|
dup line-h 0 >= [
|
|
set-line-h
|
|
] [
|
|
2dup
|
|
[ [ line-h + ] keep line-y + ] keep set-line-y
|
|
>r neg r> set-line-h
|
|
] ifte ;
|
|
|
|
M: line resize-shape ( w h line -- )
|
|
tuck resize-line-h resize-line-w ;
|
|
|
|
: line>screen ( shape -- x1 y1 x2 y2 )
|
|
[ line-x x get + ] keep
|
|
[ line-y y get + ] keep
|
|
[ line-w pick + ] keep
|
|
line-h pick + ;
|
|
|
|
: line-inside? ( p d -- ? )
|
|
dupd proj - absq 4 < ;
|
|
|
|
M: line inside? ( point line -- ? )
|
|
2dup inside-rect? [
|
|
[ line-pos - ] keep line-dir line-inside?
|
|
] [
|
|
2drop f
|
|
] ifte ;
|
|
|
|
M: line draw-shape ( line -- )
|
|
>r surface get r>
|
|
line>screen
|
|
fg rgb
|
|
aalineColor ;
|