working on visibile-children*

TODO.FACTOR.txt

@@ -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

library/alien/aliens.factor

@@ -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

library/alien/compiler.factor

@@ -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
 

library/alien/enums.factor

@@ -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

library/alien/structs.factor

@@ -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

library/alien/syntax.factor

@@ -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

library/bootstrap/boot-stage1.factor

@@ -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"

library/bootstrap/image.factor

@@ -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 ;

library/collections/sequence-sort.factor

@@ -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 ;

library/generic/generic.factor

@@ -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 ;

library/httpd/load.factor

@@ -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

library/io/files.factor

@@ -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 ;

library/sdl/sdl-gfx.factor

@@ -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" ]

library/sdl/sdl-utils.factor

@@ -52,8 +52,8 @@ SYMBOL: bpp
 
 : must-lock-surface? ( surface -- ? )
     #! This is a macro in SDL_video.h.
-    dup sdl-surface-offset 0 = [
+    dup surface-offset 0 = [
-        sdl-surface-flags
+        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 )
+: surface-rect ( x y surface -- rect )
-    dup sdl-surface-w swap sdl-surface-h make-rect ;
+    dup surface-w swap surface-h make-rect ;

library/sdl/sdl-video.factor

@@ -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*" "sdl-rect*"
-        "surface*" "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"

library/test/benchmark/sort.factor

@@ -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

library/test/sequences.factor

@@ -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

library/ui/gadgets.factor

@@ -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 )
+: >absolute ( rect -- rect )
-    rect-loc origin get v+ ;
+    dup rect-loc origin get v+ dup rot rect-dim v+ <rect> ;
-
-: screen-bounds ( rect -- rect )
-    dup screen-loc swap rect-dim <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

library/ui/layouts.factor

@@ -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 )
+M: pack visible-children* ( rect pack -- list )
-!     dup pack-vector -rot gadget-children >r rect-extent r>
+    dup pack-vector -rot gadget-children >r rect-extent r>
-!     [ rect-loc origin get v+ v- over v. ] binsearch-slice nip ;
+    [ pack-comparator ] binsearch-slice nip ;
 
 TUPLE: stack ;
 

library/ui/paint.factor

@@ -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 -- )

library/ui/text.factor

@@ -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
+        [ surface-rect ] keep swap surface get 0 0
-    ] keep sdl-surface-rect swap rot SDL_UpperBlit drop
+    ] keep surface-rect swap rot SDL_UpperBlit drop
     surface get dup must-lock-surface? [
         SDL_LockSurface
     ] when drop ;

library/vocabularies.factor

@@ -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.