steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

working on visibile-children*

cvs
Slava Pestov 2005-08-24 14:19:09 +00:00
parent 38a5f01320
commit c3d92a0b4e
22 changed files with 116 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -22,7 +22,6 @@
- icons
- use incremental strategy for all pack layouts where possible
- multiline editing in listener
- sort out clipping off-by-one flaw when filling rectangles
- better menu positioning
- only redraw dirty gadgets
- get stuff in examples dir running in the ui

2
library/alien/aliens.factor
View File

@ -41,4 +41,6 @@ M: alien = ( obj obj -- ? )
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
: DLL" skip-blank parse-string dlopen swons ; parsing
: ALIEN: scan-word <alien> swons ; parsing

19
library/alien/compiler.factor
View File

@ -3,7 +3,7 @@
IN: alien
USING: assembler compiler compiler-backend compiler-frontend
errors generic hashtables inference io kernel lists math
namespaces prettyprint sequences strings words ;
namespaces prettyprint sequences strings words parser ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
@ -130,6 +130,23 @@ M: alien-node linearize-node* ( node -- )
[ dup parameters stack-space %cleanup , ] unless
linearize-return ;
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
[ drop { } { } ] [ 2unseq ] ifte ;
: parse-arglist ( lst -- types stack effect )
unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
] make-string ;
: (define-c-word) ( type lib func types stack-effect -- )
>r over create-in >r
[ alien-invoke ] cons cons cons cons r> swap define-compound
word r> "stack-effect" set-word-prop ;
: define-c-word ( type lib func function-args -- )
[ "()" subseq? not ] subset parse-arglist (define-c-word) ;
\ alien-invoke [ [ string object string general-list ] [ ] ]
"infer-effect" set-word-prop

23
library/alien/enums.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: kernel lists math parser words ;
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan string>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing

18
library/alien/structs.factor
View File

@ -38,21 +38,3 @@ math namespaces parser sequences strings words ;
]
"struct-name" get define-c-type
"struct-name" get "in" get init-c-type ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
define-struct-type ; parsing

57
library/alien/syntax.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005 Alex Chapman.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: compiler kernel lists namespaces parser sequences words ;
USING: compiler kernel lists math namespaces parser
sequences words ;
! usage of 'LIBRARY:' and 'FUNCTION:' :
!
@ -22,23 +23,6 @@ USING: compiler kernel lists namespaces parser sequences words ;
: LIBRARY: scan "c-library" set ; parsing
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
[ drop { } { } ] [ 2unseq ] ifte ;
: parse-arglist ( lst -- types stack effect )
unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
] make-string ;
: (define-c-word) ( type lib func types stack-effect -- )
>r over create-in >r
[ alien-invoke ] cons cons cons cons r> swap define-compound
word r> "stack-effect" set-word-prop ;
: define-c-word ( type lib func function-args -- )
[ "()" subseq? not ] subset parse-arglist (define-c-word) ;
: FUNCTION:
scan "c-library" get scan string-mode on
[ string-mode off define-c-word ] [ ] ; parsing
@ -47,4 +31,39 @@ USING: compiler kernel lists namespaces parser sequences words ;
#! TYPEDEF: old new
scan scan typedef ; parsing
: DLL" skip-blank parse-string dlopen swons ; parsing
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
define-struct-type ; parsing
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan string>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing

1
library/bootstrap/boot-stage1.factor
View File

@ -142,7 +142,6 @@ sequences io vectors words ;
"/library/compiler/compiler.factor"
"/library/alien/c-types.factor"
"/library/alien/enums.factor"
"/library/alien/structs.factor"
"/library/alien/compiler.factor"
"/library/alien/syntax.factor"

12
library/bootstrap/image.factor
View File

@ -14,6 +14,9 @@ USING: errors generic hashtables kernel lists
math namespaces parser prettyprint sequences sequences io
strings vectors words ;
! If true in current namespace, we are bootstrapping.
SYMBOL: bootstrapping?
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -278,8 +281,9 @@ M: hashtable ' ( hashtable -- pointer )
"Writing image to " write dup write "..." print
<file-writer> [ (write-image) ] with-stream ;
: with-minimal-image ( quot -- image )
: with-image ( quot -- image )
[
bootstrapping? on
800000 <vector> image set
20000 <hashtable> objects set
call
@ -288,15 +292,13 @@ M: hashtable ' ( hashtable -- pointer )
image get
] with-scope ;
: with-image ( quot -- image )
#! The quotation leaves a boot quotation on the stack.
[ begin call end ] with-minimal-image ;
: make-image ( name -- )
#! Make a bootstrap image.
[
begin
"/library/bootstrap/boot-stage1.factor" run-resource
namespace global [ "foobar" set ] bind
end
] with-image
swap write-image ;

4
library/collections/sequence-sort.factor
View File

@ -78,6 +78,10 @@ IN: sequences
: sort ( seq quot -- seq | quot: elt elt -- -1/0/1 )
swap [ swap nsort ] immutable ; inline
: number-sort ( seq -- seq ) [ - ] sort ;
: string-sort ( seq -- seq ) [ lexi ] sort ;
: binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 )
swap dup empty?
[ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;

4
library/generic/generic.factor
View File

@ -101,7 +101,7 @@ PREDICATE: compound generic ( word -- ? )
M: generic definer drop \ G: ;
: lookup-union ( typelist -- class )
[ - ] sort typemap get hash [ object ] unless* ;
number-sort typemap get hash [ object ] unless* ;
: class-or ( class class -- class )
#! Return a class that both classes are subclasses of.
@ -139,4 +139,4 @@ M: generic definer drop \ G: ;
: define-class ( class metaclass -- )
dupd "metaclass" set-word-prop
dup types [ - ] sort typemap get set-hash ;
dup types number-sort typemap get set-hash ;

18
library/httpd/load.factor Normal file
View File

@ -0,0 +1,18 @@
USING: kernel parser sequences io ;
[
"/library/httpd/http-common.factor"
"/library/httpd/mime.factor"
"/library/httpd/html-tags.factor"
"/library/httpd/html.factor"
"/library/httpd/responder.factor"
"/library/httpd/httpd.factor"
"/library/httpd/file-responder.factor"
"/library/httpd/test-responder.factor"
"/library/httpd/resource-responder.factor"
"/library/httpd/cont-responder.factor"
"/library/httpd/browser-responder.factor"
"/library/httpd/default-responders.factor"
"/library/httpd/http-client.factor"
] [
dup print run-resource
] each

2
library/io/files.factor
View File

@ -8,7 +8,7 @@ USING: kernel lists namespaces sequences strings ;
: path+ ( path path -- path ) "/" swap append3 ;
: exists? ( file -- ? ) stat >boolean ;
: directory? ( file -- ? ) stat car ;
: directory ( dir -- list ) (directory) [ lexi ] sort ;
: directory ( dir -- list ) (directory) string-sort ;
: file-length ( file -- length ) stat third ;
: file-extension ( filename -- extension )
"." split cdr dup [ peek ] when ;

10
library/sdl/sdl-gfx.factor
View File

@ -67,16 +67,6 @@ IN: sdl USING: alien ;
[ "surface*" "short" "short" "short" "short" "uint" ]
alien-invoke ;
: pieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "pieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
alien-invoke ;
: filledPieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "filledPieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
alien-invoke ;
: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "trigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]

8
library/sdl/sdl-utils.factor
View File

@ -52,8 +52,8 @@ SYMBOL: bpp
: must-lock-surface? ( surface -- ? )
#! This is a macro in SDL_video.h.
dup sdl-surface-offset 0 = [
sdl-surface-flags
dup surface-offset 0 = [
surface-flags
SDL_HWSURFACE SDL_ASYNCBLIT bitor SDL_RLEACCEL bitor
bitand 0 = not
] [
@ -71,5 +71,5 @@ SYMBOL: bpp
] ifte SDL_Flip drop
] with-scope ; inline
: sdl-surface-rect ( x y surface -- rect )
dup sdl-surface-w swap sdl-surface-h make-rect ;
: surface-rect ( x y surface -- rect )
dup surface-w swap surface-h make-rect ;

10
library/sdl/sdl-video.factor
View File

@ -58,7 +58,7 @@ BEGIN-STRUCT: sdl-format
FIELD: uchar alpha
END-STRUCT
BEGIN-STRUCT: sdl-surface
BEGIN-STRUCT: surface
FIELD: uint flags
FIELD: sdl-format* format
FIELD: int w
@ -120,7 +120,7 @@ END-STRUCT
"void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ;
: SDL_SetClipRect ( surface rect -- ? )
"bool" "sdl" "SDL_SetClipRect" [ "surface*" "rect*" ] alien-invoke ;
"bool" "sdl" "SDL_SetClipRect" [ "surface*" "sdl-rect*" ] alien-invoke ;
: SDL_FreeSurface ( surface -- )
"void" "sdl" "SDL_FreeSurface" [ "surface*" ] alien-invoke ;
@ -129,14 +129,14 @@ END-STRUCT
#! The blit function should not be called on a locked
#! surface.
"int" "sdl" "SDL_UpperBlit" [
"surface*" "rect*"
"surface*" "rect*"
"surface*" "sdl-rect*"
"surface*" "sdl-rect*"
] alien-invoke ;
: SDL_FillRect ( surface rect color -- n )
#! If rect is null, fills entire surface.
"bool" "sdl" "SDL_FillRect"
[ "surface*" "rect*" "uint" ] alien-invoke ;
[ "surface*" "sdl-rect*" "uint" ] alien-invoke ;
: SDL_WM_SetCaption ( title icon -- )
"void" "sdl" "SDL_WM_SetCaption"

2
library/test/benchmark/sort.factor
View File

@ -2,6 +2,6 @@ IN: temporary
USING: compiler kernel math sequences test ;
: sort-benchmark
100000 [ drop 0 10000 random-int ] map [ - ] sort drop ; compiled
100000 [ drop 0 10000 random-int ] map number-sort drop ; compiled
[ ] [ sort-benchmark ] unit-test

4
library/test/sequences.factor
View File

@ -147,7 +147,7 @@ unit-test
sorter-seq >vector nip
] unit-test
[ [ ] ] [ [ ] [ - ] sort ] unit-test
[ [ ] ] [ [ ] number-sort ] unit-test
: pairs ( seq quot -- )
swap dup length 1 - [
@ -166,6 +166,6 @@ unit-test
[ t ] [
100 [
drop
1000 [ drop 0 1000 random-int ] map [ - ] sort [ - ] sorted?
1000 [ drop 0 1000 random-int ] map number-sort [ - ] sorted?
] all?
] unit-test

10
library/ui/gadgets.factor
View File

@ -18,14 +18,11 @@ GENERIC: inside? ( loc rect -- ? )
: rect-extent ( rect -- loc dim )
dup rect-loc dup rot rect-dim v+ ;
: screen-loc ( rect -- loc )
rect-loc origin get v+ ;
: screen-bounds ( rect -- rect )
dup screen-loc swap rect-dim <rect> ;
: >absolute ( rect -- rect )
dup rect-loc origin get v+ dup rot rect-dim v+ <rect> ;
M: rect inside? ( loc rect -- ? )
screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
>absolute rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
>r v- { 0 0 0 } r> vbetween? conjunction ;
: intersect ( rect rect -- rect )
@ -114,7 +111,6 @@ M: gadget pick-up* ( point gadget -- gadget )
#! in any subgadget. If not, see if it is contained in the
#! box delegate.
dup gadget-visible? >r 2dup inside? r> drop [
[ rect-loc v- ] keep 2dup
pick-up* [ pick-up ] [ nip ] ?ifte
] [
2drop f

10
library/ui/layouts.factor
View File

@ -83,16 +83,18 @@ M: pack pref-dim ( pack -- dim )
M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
: pack-comparator rect-loc origin get v+ v- over v. ;
: pick-up-fast ( axis point gadgets -- gadget )
[ rect-loc v- over v. ] binsearch* nip ;
[ pack-comparator ] binsearch* nip ;
M: pack pick-up* ( point pack -- gadget )
dup pack-vector pick rot gadget-children
pick-up-fast tuck inside? [ drop f ] unless ;
! M: pack visible-children* ( rect pack -- list )
! dup pack-vector -rot gadget-children >r rect-extent r>
! [ rect-loc origin get v+ v- over v. ] binsearch-slice nip ;
M: pack visible-children* ( rect pack -- list )
dup pack-vector -rot gadget-children >r rect-extent r>
[ pack-comparator ] binsearch-slice nip ;
TUPLE: stack ;

4
library/ui/paint.factor
View File

@ -18,7 +18,7 @@ SYMBOL: clip
GENERIC: visible-children* ( rect gadget -- list )
M: gadget visible-children* ( rect gadget -- list )
gadget-children [ screen-bounds intersects? ] subset-with ;
gadget-children [ >absolute intersects? ] subset-with ;
: visible-children ( gadget -- list )
clip get swap visible-children* ;
@ -26,7 +26,7 @@ M: gadget visible-children* ( rect gadget -- list )
GENERIC: draw-gadget* ( gadget -- )
: translate&clip ( gadget -- )
screen-bounds dup rect-loc origin set
>absolute dup rect-loc origin set
clip [ intersect dup ] change set-clip ;
: draw-gadget ( gadget -- )

4
library/ui/text.factor
View File

@ -7,8 +7,8 @@ strings styles io ;
: draw-surface ( x y surface -- )
surface get SDL_UnlockSurface
[
[ sdl-surface-rect ] keep swap surface get 0 0
] keep sdl-surface-rect swap rot SDL_UpperBlit drop
[ surface-rect ] keep swap surface get 0 0
] keep surface-rect swap rot SDL_UpperBlit drop
surface get dup must-lock-surface? [
SDL_LockSurface
] when drop ;

2
library/vocabularies.factor
View File

@ -11,7 +11,7 @@ SYMBOL: vocabularies
: vocabs ( -- list )
#! Push a list of vocabularies.
vocabularies get hash-keys [ lexi ] sort ;
vocabularies get hash-keys string-sort ;
: vocab ( name -- vocab )
#! Get a vocabulary.