added norm, proj words for vectors, removed dot/proj for complex numbers, more UI strippage
Slava Pestov
parent
2b4c49c33a
commit
5c9955fa52
|
|
@ -32,16 +32,13 @@
|
|||
+ ui:
|
||||
|
||||
- faster layout
|
||||
- tiled window manager
|
||||
- faster repaint
|
||||
- console with presentations
|
||||
- ui browser
|
||||
- auto-updating inspector, mirrors abstraction
|
||||
- mouse enter onto overlapping with interior, but not child, gadget
|
||||
- rollovers broken in inspector
|
||||
- menu dragging
|
||||
- fix up the min thumb size hack
|
||||
- frame gap
|
||||
|
||||
+ ffi:
|
||||
|
||||
|
|
|
|||
|
|
@ -175,8 +175,8 @@ M: infix-word see
|
|||
: || ;
|
||||
|
||||
! Install arithmetic operators into words
|
||||
[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor proj
|
||||
bitxor dot rem || ] [
|
||||
[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor
|
||||
bitxor rem || ] [
|
||||
dup arith-2 set-word-prop
|
||||
] each
|
||||
[ [[ = new= ]] [[ > new> ]] [[ < new< ]] [[ >= new>= ]] [[ <= new<= ]] ] [
|
||||
|
|
|
|||
|
|
@ -94,8 +94,6 @@ USE: test
|
|||
] repeat
|
||||
] make-vector nip ;
|
||||
|
||||
: absq >rect swap sq swap sq + ; inline
|
||||
|
||||
: iter ( c z nb-iter -- x )
|
||||
over absq 4 >= over 0 = or [
|
||||
nip nip
|
||||
|
|
|
|||
|
|
@ -46,14 +46,6 @@ M: number = ( n n -- ? ) number= ;
|
|||
|
||||
: absq >rect swap sq swap sq + ;
|
||||
|
||||
: dot ( #{ x1 x2 }# #{ y1 y2 }# -- x1*y1+x2*y2 )
|
||||
over real over real * >r
|
||||
swap imaginary swap imaginary * r> + ;
|
||||
|
||||
: proj ( u v -- w )
|
||||
#! Orthogonal projection of u onto v.
|
||||
[ [ dot ] keep absq /f ] keep * ;
|
||||
|
||||
IN: math-internals
|
||||
|
||||
: 2>rect ( x y -- xr yr xi yi )
|
||||
|
|
|
|||
|
|
@ -4,10 +4,12 @@ IN: matrices
|
|||
USING: errors generic kernel lists math namespaces sequences
|
||||
vectors ;
|
||||
|
||||
! Vector operations
|
||||
: n*v ( n vec -- vec ) [ * ] map-with ;
|
||||
: v*n ( vec n -- vec ) swap n*v ;
|
||||
: n/v ( n vec -- vec ) [ / ] map-with ;
|
||||
: v/n ( vec n -- vec ) swap [ swap / ] map-with ;
|
||||
|
||||
! Vector operations
|
||||
: v+ ( v v -- v ) [ + ] 2map ;
|
||||
: v- ( v v -- v ) [ - ] 2map ;
|
||||
: v* ( v v -- v ) [ * ] 2map ;
|
||||
|
|
@ -27,6 +29,13 @@ vectors ;
|
|||
! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
|
||||
: v. ( v v -- x ) v** sum ;
|
||||
|
||||
: norm-sq ( v -- n ) 0 [ absq + ] reduce ;
|
||||
: norm ( v -- n ) norm-sq sqrt ;
|
||||
|
||||
: proj ( u v -- w )
|
||||
#! Orthogonal projection of u onto v.
|
||||
[ [ v. ] keep norm-sq v/n ] keep n*v ;
|
||||
|
||||
: cross-trace ( v1 v2 i1 i2 -- v1 v2 n )
|
||||
pick nth >r pick nth r> * ;
|
||||
|
||||
|
|
@ -44,6 +53,7 @@ vectors ;
|
|||
! Matrices
|
||||
! The major dimension is the number of elements per row.
|
||||
TUPLE: matrix rows cols sequence ;
|
||||
|
||||
: >matrix<
|
||||
[ matrix-rows ] keep
|
||||
[ matrix-cols ] keep
|
||||
|
|
|
|||
|
|
@ -4,8 +4,6 @@ IN: gadgets
|
|||
USING: errors generic hashtables kernel lists math matrices
|
||||
namespaces sdl vectors ;
|
||||
|
||||
! A border lays out its children on top of each other, all with
|
||||
! a 5-pixel padding.
|
||||
TUPLE: border size ;
|
||||
|
||||
C: border ( child delegate size -- border )
|
||||
|
|
@ -13,29 +11,19 @@ C: border ( child delegate size -- border )
|
|||
[ set-delegate ] keep
|
||||
[ over [ add-gadget ] [ 2drop ] ifte ] keep ;
|
||||
|
||||
: empty-border ( child -- border )
|
||||
<empty-gadget> 5 <border> ;
|
||||
|
||||
: line-border ( child -- border )
|
||||
0 0 0 0 <etched-rect> <gadget> 5 <border> ;
|
||||
0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
|
||||
|
||||
: filled-border ( child -- border )
|
||||
<plain-gadget> 5 <border> ;
|
||||
: layout-border-loc ( border -- )
|
||||
dup border-size swap gadget-child set-gadget-loc ;
|
||||
|
||||
: gadget-child gadget-children car ;
|
||||
|
||||
: layout-border-x/y ( border -- )
|
||||
dup border-size dup rot gadget-child move-gadget ;
|
||||
|
||||
: layout-border-w/h ( border -- )
|
||||
[ border-size 2 * ] keep
|
||||
[ shape-w over - ] keep
|
||||
[ shape-h rot - ] keep
|
||||
gadget-child resize-gadget ;
|
||||
: layout-border-dim ( border -- )
|
||||
dup shape-dim over border-size 2 v*n v-
|
||||
swap gadget-child set-gadget-dim ;
|
||||
|
||||
M: border pref-dim ( border -- dim )
|
||||
[ border-size dup dup 3vector 2 v*n ] keep
|
||||
[ border-size 2 v*n ] keep
|
||||
gadget-child pref-dim v+ ;
|
||||
|
||||
M: border layout* ( border -- )
|
||||
dup layout-border-x/y layout-border-w/h ;
|
||||
dup layout-border-loc layout-border-dim ;
|
||||
|
|
|
|||
|
|
@ -40,6 +40,3 @@ sequences io sequences styles ;
|
|||
dup [ button-update ] [ mouse-leave ] set-action
|
||||
dup [ button-update ] [ mouse-enter ] set-action
|
||||
[ drop ] [ drag 1 ] set-action ;
|
||||
|
||||
: <button> ( label action -- button )
|
||||
>r <label> line-border dup r> button-action button-gestures ;
|
||||
|
|
|
|||
|
|
@ -1,48 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel lists math namespaces sdl sequences
|
||||
styles ;
|
||||
|
||||
: check-size 8 ;
|
||||
|
||||
: <check> ( -- cross )
|
||||
0 0 check-size dup <line> <gadget>
|
||||
>r check-size 0 check-size neg check-size <line> <gadget> r>
|
||||
2list <stack> ;
|
||||
|
||||
TUPLE: checkbox bevel selected? ;
|
||||
|
||||
: init-checkbox-bevel ( bevel checkbox -- )
|
||||
2dup set-checkbox-bevel add-gadget ;
|
||||
|
||||
: update-checkbox ( checkbox -- )
|
||||
#! Really, there should only be one child.
|
||||
dup checkbox-bevel gadget-children [ unparent ] each
|
||||
dup checkbox-selected? [
|
||||
<check>
|
||||
] [
|
||||
0 0 check-size dup <rectangle> <gadget>
|
||||
] ifte swap checkbox-bevel add-gadget ;
|
||||
|
||||
: toggle-checkbox ( checkbox -- )
|
||||
dup checkbox-selected? not over set-checkbox-selected?
|
||||
update-checkbox ;
|
||||
|
||||
: checkbox-update ( checkbox -- )
|
||||
dup button-pressed? >r checkbox-bevel r>
|
||||
reverse-video set-paint-prop ;
|
||||
|
||||
: checkbox-actions ( checkbox -- )
|
||||
dup [ toggle-checkbox ] [ action ] set-action
|
||||
dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
|
||||
dup [ checkbox-update ] [ button-down 1 ] set-action
|
||||
dup [ checkbox-update ] [ mouse-leave ] set-action
|
||||
[ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
|
||||
|
||||
C: checkbox ( label -- checkbox )
|
||||
<line-shelf> over set-delegate
|
||||
[ f line-border swap init-checkbox-bevel ] keep
|
||||
[ >r <label> r> add-gadget ] keep
|
||||
dup checkbox-actions
|
||||
dup update-checkbox ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel line-editor lists math namespaces sdl
|
||||
sequences strings styles vectors ;
|
||||
USING: generic kernel line-editor lists math matrices namespaces
|
||||
sdl sequences strings styles vectors ;
|
||||
|
||||
! An editor gadget wraps a line editor object and passes
|
||||
! gestures to the line editor.
|
||||
|
|
@ -89,7 +89,7 @@ M: editor user-input* ( ch editor -- ? )
|
|||
scroll>bottom t ;
|
||||
|
||||
M: editor pref-dim ( editor -- dim )
|
||||
dup editor-text label-size >r 1 + r> 0 3vector ;
|
||||
dup editor-text label-size { 1 0 0 } v+ ;
|
||||
|
||||
M: editor layout* ( editor -- )
|
||||
dup editor-caret over caret-size rot resize-gadget
|
||||
|
|
|
|||
|
|
@ -1,58 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel lists math namespaces sdl styles ;
|
||||
|
||||
! An ellipse.
|
||||
TUPLE: ellipse x y w h ;
|
||||
M: ellipse shape-x ellipse-x ;
|
||||
M: ellipse shape-y ellipse-y ;
|
||||
M: ellipse shape-w ellipse-w ;
|
||||
M: ellipse shape-h ellipse-h ;
|
||||
|
||||
C: ellipse ( x y w h -- line )
|
||||
#! We handle negative w/h for convenience.
|
||||
>r fix-neg >r fix-neg r> r>
|
||||
[ set-ellipse-h ] keep
|
||||
[ set-ellipse-w ] keep
|
||||
[ set-ellipse-y ] keep
|
||||
[ set-ellipse-x ] keep ;
|
||||
|
||||
M: ellipse move-shape ( x y line -- )
|
||||
tuck set-ellipse-y set-ellipse-x ;
|
||||
|
||||
M: ellipse resize-shape ( w h line -- )
|
||||
tuck set-ellipse-h set-ellipse-w ;
|
||||
|
||||
: ellipse>screen ( shape -- x y rx ry )
|
||||
[ dup shape-x swap shape-w 2 /i + x get + ] keep
|
||||
[ dup shape-y swap shape-h 2 /i + y get + ] keep
|
||||
[ shape-w 2 /i ] keep
|
||||
shape-h 2 /i ;
|
||||
|
||||
M: ellipse inside? ( point ellipse -- ? )
|
||||
ellipse>screen swap sq swap sq
|
||||
2dup * >r >r >r
|
||||
pick shape-y - sq
|
||||
>r swap shape-x - sq r>
|
||||
r> * r> rot * + r> <= ;
|
||||
|
||||
M: ellipse draw-shape drop ;
|
||||
|
||||
TUPLE: hollow-ellipse ;
|
||||
|
||||
C: hollow-ellipse ( x y w h -- ellipse )
|
||||
[ >r <ellipse> r> set-delegate ] keep ;
|
||||
|
||||
M: hollow-ellipse draw-shape ( ellipse -- )
|
||||
>r surface get r> ellipse>screen fg rgb
|
||||
ellipseColor ;
|
||||
|
||||
TUPLE: plain-ellipse ;
|
||||
|
||||
C: plain-ellipse ( x y w h -- ellipse )
|
||||
[ >r <ellipse> r> set-delegate ] keep ;
|
||||
|
||||
M: plain-ellipse draw-shape ( ellipse -- )
|
||||
>r surface get r> ellipse>screen bg rgb
|
||||
filledEllipseColor ;
|
||||
|
|
@ -37,6 +37,8 @@ C: frame ( -- frame )
|
|||
dup frame-left , dup frame-center , frame-right ,
|
||||
] make-list ;
|
||||
|
||||
: pref-size pref-dim 3unseq drop ;
|
||||
|
||||
: max-h pref-size nip height [ max ] change ;
|
||||
: max-w pref-size drop width [ max ] change ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ sequences vectors ;
|
|||
! delegates to its shape.
|
||||
TUPLE: gadget paint gestures relayout? redraw? parent children ;
|
||||
|
||||
: gadget-child gadget-children car ;
|
||||
|
||||
C: gadget ( shape -- gadget )
|
||||
[ set-delegate ] keep
|
||||
[ <namespace> swap set-gadget-paint ] keep
|
||||
|
|
@ -77,8 +79,6 @@ GENERIC: pref-dim ( gadget -- dim )
|
|||
|
||||
M: gadget pref-dim shape-dim ;
|
||||
|
||||
: pref-size pref-dim 3unseq drop ;
|
||||
|
||||
GENERIC: layout* ( gadget -- )
|
||||
|
||||
: prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;
|
||||
|
|
|
|||
|
|
@ -10,11 +10,11 @@ TUPLE: label text ;
|
|||
C: label ( text -- label )
|
||||
<empty-gadget> over set-delegate [ set-label-text ] keep ;
|
||||
|
||||
: label-size ( gadget text -- w h )
|
||||
>r gadget-font r> size-string ;
|
||||
: label-size ( gadget text -- dim )
|
||||
>r gadget-font r> size-string 0 3vector ;
|
||||
|
||||
M: label pref-dim ( label -- dim )
|
||||
dup label-text label-size 0 3vector ;
|
||||
dup label-text label-size ;
|
||||
|
||||
M: label draw-shape ( label -- )
|
||||
[ dup gadget-font swap label-text ] keep
|
||||
|
|
|
|||
|
|
@ -1,71 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: generic kernel lists math namespaces sdl styles ;
|
||||
|
||||
! 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 ;
|
||||
|
|
@ -4,8 +4,6 @@ USING: kernel parser sequences io ;
|
|||
"/library/ui/shapes.factor"
|
||||
"/library/ui/points.factor"
|
||||
"/library/ui/rectangles.factor"
|
||||
"/library/ui/lines.factor"
|
||||
"/library/ui/ellipses.factor"
|
||||
"/library/ui/gadgets.factor"
|
||||
"/library/ui/hierarchy.factor"
|
||||
"/library/ui/paint.factor"
|
||||
|
|
@ -19,7 +17,6 @@ USING: kernel parser sequences io ;
|
|||
"/library/ui/world.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
"/library/ui/checkboxes.factor"
|
||||
"/library/ui/line-editor.factor"
|
||||
"/library/ui/events.factor"
|
||||
"/library/ui/scrolling.factor"
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ USING: generic kernel lists math namespaces sequences ;
|
|||
show-glass ;
|
||||
|
||||
: menu-item-border ( child -- border )
|
||||
<plain-gadget> 1 <border> ;
|
||||
<plain-gadget> { 1 1 0 } <border> ;
|
||||
|
||||
: <menu-item> ( label quot -- gadget )
|
||||
>r <label> menu-item-border dup r> button-gestures ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue