centralized notion of gadget orientation; moved httpd unit tests to contrib

CHANGES.html

@@ -84,6 +84,7 @@ However, most uses of <code>catch</code> can be replaced by <code>cleanup</code>
 
 <ul>
 
+<li>The HTTP server and client has been moved from <code>library/httpd/</code> to <code>library/contrib/</code>.</li>
 <li>Intel 8080 CPU and Space Invaders emulator in <code>contrib/space-invaders</code> (Chris Double)</li>
 <li>AOL Instant Messenger chat client library in <code>contrib/aim</code> (Doug Coleman)</li>
 <li>Cairo graphics library binding in <code>contrib/cairo</code>. (Sampo Vuori)</li>

TODO.FACTOR.txt

@@ -1,5 +1,17 @@
+0.79:
+
+- fix remaining cosmetic issues in UI
+- investigate UI on Linux/x86
+- swap @{ and { syntax
+- get stuff in examples dir running in the ui
+- [ ... is annoying
+  perhaps on the last line of output, if a block doesn't fit, print
+  it anyway?
+- apropos: use new smarter completion?
+
 + ui:
 
+- keyboard completion
 - get outliner working with lots of lines of output
 - listener continuations
 - fix up the min thumb size hack
@@ -14,7 +26,6 @@
 - find out why so many small bignums get consed
 - use incremental strategy for all pack layouts where possible
 - multiline editing in listener
-- get stuff in examples dir running in the ui
 - text selection
 - clipboard support
 
@@ -27,15 +38,9 @@
 + misc
 
 - code walker & exceptions
-- load all sources in stage1
 - investigate if rehashing on startup is really necessary
 - remove word transfer hack in bootstrap
-- [ ... is annoying
-  perhaps on the last line of output, if a block doesn't fit, print
-  it anyway?
-- apropos: use new smarter completion?
 - signal handler should not lose stack pointers
-- http keep alive, and range get
 
 + ffi:
 
@@ -78,7 +83,6 @@
 - slice: if sequence or seq start is changed, abstraction violation
 - split: return vectors
 - set-path: iterative
-- swap @{ }@ and { } syntax
 - specialized arrays
 - instances: do not use make-list
 - >c/c>: vector stack

contrib/README.txt

@@ -5,6 +5,8 @@ library, but is useful enough to ship with the Factor distribution.
 
 - contrib/algebra/ -- infix math syntax (Daniel Ehrenberg)
 
+- contrib/cairo/ -- cairo bindings (Sampo Vuori)
+
 - contrib/concurrency/ -- Erlang/Termite-style concurrency (Chris Double)
 
 - contrib/cont-responder/ -- additional examples and tools for the
@@ -12,6 +14,10 @@ library, but is useful enough to ship with the Factor distribution.
   
 - contrib/crypto/ -- MD5 and SHA1 cryptographic hashes (Doug Coleman)
 
+- contrib/httpd/ -- HTTP server and client (Slava Pestov, Chris Double)
+
+- contrib/math/ -- extended math library (Doug Coleman)
+
 - contrib/parser-combinators/ -- Lazy lists and Haskell-style parser
   combinators (Chris Double)
 
@@ -27,7 +33,3 @@ library, but is useful enough to ship with the Factor distribution.
 - contrib/dlists.factor -- double-linked-lists (Mackenzie Straight)
 
 - contrib/xml.factor -- XML parser and writer (Daniel Ehrenberg)
-
-- contrib/cairo/ -- cairo bindings (Sampo Vuori)
-
-- contrib/math/ -- extended math library (Doug Coleman)

contrib/httpd/load.factor

@@ -11,6 +11,10 @@ USING: kernel parser sequences io ;
     "contrib/httpd/browser-responder.factor"
     "contrib/httpd/default-responders.factor"
     "contrib/httpd/http-client.factor"
+    "contrib/httpd/test/html.factor"
+    "contrib/httpd/test/http-client.factor"
+    "contrib/httpd/test/httpd.factor"
+    "contrib/httpd/test/url-encoding.factor"
 ] [
     dup print run-file
 ] each

library/help/tutorial.factor

@@ -9,7 +9,7 @@ namespaces sdl sequences strings styles ;
 
 : <underline> ( -- gadget )
     <gadget>
-    dup << gradient f @{ 1 0 0 }@ @{ @{ 64 64 64 }@ @{ 255 255 255 }@ }@ >>
+    dup << gradient f @{ @{ 64 64 64 }@ @{ 255 255 255 }@ }@ >>
     interior set-paint-prop
     @{ 0 10 0 }@ over set-gadget-dim ;
 
@@ -358,7 +358,7 @@ M: general-list tutorial-line
 
 : tutorial-theme
     dup @{ 204 204 255 }@ background set-paint-prop
-    dup << gradient f @{ 0 1 0 }@ @{ @{ 204 204 255 }@ @{ 255 204 255 }@ }@ >>
+    dup << gradient f @{ @{ 204 204 255 }@ @{ 255 204 255 }@ }@ >>
     interior set-paint-prop
     dup "Sans Serif" font set-paint-prop
     16 font-size set-paint-prop ;

library/test/test.factor

@@ -88,9 +88,7 @@ SYMBOL: failures
         "stream" "math/bitops"
         "math/math-combinators" "math/rational" "math/float"
         "math/complex" "math/irrational"
-        "math/integer"
-        "httpd/url-encoding" "httpd/html" "httpd/httpd"
-        "httpd/http-client" "threads" "parsing-word"
+        "math/integer" "threads" "parsing-word"
         "inference" "interpreter" "alien"
         "gadgets/line-editor" "gadgets/rectangles"
         "gadgets/frames" "memory"

library/ui/buttons.factor

@@ -39,7 +39,7 @@ styles threads ;
 TUPLE: button ;
 
 C: button ( gadget quot -- button )
-    rot <border> dup @{ 0 1 0 }@ button-theme
+    rot <border> dup button-theme
     over set-gadget-delegate
     [ swap button-gestures ] keep ;
 

library/ui/gadgets.factor

@@ -44,7 +44,7 @@ M: array rect-dim drop @{ 0 0 0 }@ ;
 ! actions, and a reference to the gadget's parent.
 TUPLE: gadget
     paint gestures visible? relayout? root?
-    parent children ;
+    parent children orientation ;
 
 : show-gadget t swap set-gadget-visible? ;
 
@@ -55,7 +55,8 @@ M: gadget = eq? ;
 : gadget-child gadget-children first ;
 
 C: gadget ( -- gadget )
-    @{ 0 0 0 }@ dup <rect> over set-delegate dup show-gadget ;
+    @{ 0 0 0 }@ dup <rect> over set-delegate dup show-gadget
+    @{ 0 1 0 }@ over set-gadget-orientation ;
 
 : delegate>gadget ( tuple -- ) <gadget> swap set-delegate ;
 

library/ui/incremental.factor

@@ -10,7 +10,7 @@ USING: gadgets generic io kernel math namespaces ;
 ! change size, the incremental strategy does not work.
 
 ! The cursor is the current size of the incremental pack.
-! New gadgets are added at cursor-cursor*pack-vector.
+! New gadgets are added at cursor-cursor*gadget-orientation.
 
 TUPLE: incremental cursor ;
 
@@ -27,13 +27,13 @@ M: incremental pref-dim ( incremental -- dim )
     [
         swap rect-dim swap incremental-cursor
         2dup v+ >r vmax r>
-    ] keep  pack-vector set-axis ;
+    ] keep  gadget-orientation set-axis ;
 
 : update-cursor ( gadget incremental -- )
     [ next-cursor ] keep set-incremental-cursor ;
 
 : incremental-loc ( gadget incremental -- )
-    dup incremental-cursor swap pack-vector v*
+    dup incremental-cursor swap gadget-orientation v*
     swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )

library/ui/layouts.factor

@@ -58,13 +58,13 @@ DEFER: layout
         dup layout* dup layout-children
     ] when drop ;
 
-TUPLE: pack align fill gap vector ;
+TUPLE: pack align fill gap ;
 
 : pref-dims ( gadget -- list )
     gadget-children [ pref-dim ] map ;
 
 : orient ( gadget seq1 seq2 -- seq )
-    >r >r pack-vector r> r> [ pick set-axis ] 2map nip ;
+    >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
 
 : packed-dim-2 ( gadget sizes -- list )
     [ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;
@@ -93,8 +93,8 @@ C: pack ( vector -- pack )
     #! gap: between each child.
     #! fill: 0 leaves default width, 1 fills to pack width.
     #! align: 0 left, 1/2 center, 1 right.
-    [ set-pack-vector ] keep
     dup delegate>gadget
+    [ set-gadget-orientation ] keep
     0 over set-pack-align
     0 over set-pack-fill
     @{ 0 0 0 }@ over set-pack-gap ;
@@ -111,7 +111,7 @@ M: pack pref-dim ( pack -- dim )
             pref-dims [ max-dim ] keep
             [ @{ 0 0 0 }@ [ v+ ] reduce ] keep length 1 - 0 max
         ] keep pack-gap n*v v+
-    ] keep pack-vector set-axis ;
+    ] keep gadget-orientation set-axis ;
 
 M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
 
@@ -119,7 +119,7 @@ M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
     swapd [ rect-loc origin get v+ v- over v. ] binsearch nip ;
 
 M: pack children-on ( rect pack -- list )
-    dup pack-vector swap gadget-children [
+    dup gadget-orientation swap gadget-children [
         3dup
         >r >r dup rect-loc swap rect-dim v+ r> r> fast-children-on 1+
         >r

library/ui/paint.factor

@@ -100,10 +100,10 @@ M: rollover-only draw-boundary ( gadget boundary -- )
     [ delegate draw-boundary ] [ 2drop ] if ;
 
 ! Gradient pen
-TUPLE: gradient direction colors ;
+TUPLE: gradient colors ;
 
 M: gradient draw-interior ( gadget gradient -- )
-    dup gradient-direction swap gradient-colors rot rect-dim
+    over gadget-orientation swap gradient-colors rot rect-dim
     gl-gradient ;
 
 M: gadget draw-gadget* ( gadget -- )

library/ui/scrolling.factor

@@ -31,9 +31,9 @@ M: viewport pref-dim gadget-child pref-dim ;
 
 : set-slider ( page max value slider -- )
     #! page/max/value are 3-vectors.
-    [ [ slider-vector v. ] keep set-slider-value ] keep
-    [ [ slider-vector v. ] keep set-slider-max ] keep
-    [ [ slider-vector v. ] keep set-slider-page ] keep
+    [ [ gadget-orientation v. ] keep set-slider-value ] keep
+    [ [ gadget-orientation v. ] keep set-slider-max ] keep
+    [ [ gadget-orientation v. ] keep set-slider-page ] keep
     fix-slider ;
 
 : update-slider ( scroller value slider -- )

library/ui/sliders.factor

@@ -11,7 +11,7 @@ TUPLE: elevator ;
 : find-elevator [ elevator? ] find-parent ;
 
 ! A slider scrolls a viewport.
-TUPLE: slider vector elevator thumb value max page ;
+TUPLE: slider elevator thumb value max page ;
 
 : find-slider [ slider? ] find-parent ;
 
@@ -19,7 +19,7 @@ TUPLE: slider vector elevator thumb value max page ;
     #! A scaling factor such that if x is a slider co-ordinate,
     #! x*n is the screen position of the thumb, and conversely
     #! for x/n. The '1 max' calls avoid division by zero.
-    dup slider-elevator rect-dim over slider-vector v. 1 max
+    dup slider-elevator rect-dim over gadget-orientation v. 1 max
     swap slider-max 1 max / ;
 
 : slider>screen slider-scale * ;
@@ -44,7 +44,7 @@ SYMBOL: slider-changed
     [ slider-changed ] swap handle-gesture drop ;
 
 : elevator-drag ( elevator -- )
-    dup drag-loc >r find-slider r> over slider-vector v.
+    dup drag-loc >r find-slider r> over gadget-orientation v.
     over screen>slider
     swap set-slider-value* ;
 
@@ -54,9 +54,8 @@ SYMBOL: slider-changed
     [ find-elevator elevator-drag ] [ drag 1 ] set-action ;
 
 : <thumb> ( vector -- thumb )
-    <gadget> dup rot button-theme
-    t over set-gadget-root?
-    dup thumb-actions ;
+    <gadget> [ set-gadget-orientation ] keep
+    t over set-gadget-root? dup button-theme dup thumb-actions ;
 
 : slide-by ( amount gadget -- )
     #! The gadget can be any child of a slider.
@@ -67,7 +66,7 @@ SYMBOL: slider-changed
 
 : elevator-click ( elevator -- )
     dup hand get relative >r find-slider r>
-    over slider-vector v.
+    over gadget-orientation v.
     over screen>slider over slider-value - sgn
     swap slide-by-page ;
 
@@ -75,12 +74,11 @@ SYMBOL: slider-changed
     [ elevator-click ] [ button-down 1 ] set-action ;
 
 C: elevator ( vector -- elevator )
-    dup delegate>gadget
-    dup rot elevator-theme
-    dup elevator-actions ;
+    dup delegate>gadget [ set-gadget-orientation ] keep
+    dup elevator-theme dup elevator-actions ;
 
 : (layout-thumb) ( slider n -- n )
-    over slider-vector n*v swap slider-thumb ;
+    over gadget-orientation n*v swap slider-thumb ;
 
 : thumb-loc ( slider -- loc )
     dup slider-value swap slider>screen ;
@@ -93,7 +91,7 @@ C: elevator ( vector -- elevator )
 
 : layout-thumb-dim ( slider -- )
     dup dup thumb-dim (layout-thumb)
-    >r >r dup rect-dim r> rot slider-vector set-axis r>
+    >r >r dup rect-dim r> rot gadget-orientation set-axis r>
     set-gadget-dim ;
 
 : layout-thumb ( slider -- )
@@ -104,39 +102,43 @@ M: elevator layout* ( elevator -- )
 
 : slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
 
-: slider-vertical? slider-vector @{ 0 1 0 }@ = ;
+: slider-vertical? gadget-orientation @{ 0 1 0 }@ = ;
 
-: <slide-button> ( polygon amount -- )
+: <slide-button> ( orientation polygon amount -- )
     >r <polygon-gadget> dup icon-theme r>
-    [ swap slide-by-line ] curry <repeat-button> ;
+    [ swap slide-by-line ] curry <repeat-button>
+    [ set-gadget-orientation ] keep ;
 
-: <up-button> ( slider -- button )
-    slider-vertical? arrow-up arrow-left ? -1 <slide-button> ;
+: <up-button> ( slider orientation -- button )
+    swap slider-vertical? arrow-up arrow-left ? -1
+    <slide-button> ;
 
-: add-up @{ 1 1 1 }@ over slider-vector v- first2 frame-add ;
+: add-up @{ 1 1 1 }@ over gadget-orientation v- first2 frame-add ;
 
-: <down-button> ( slider -- button )
-    slider-vertical? arrow-down arrow-right ? 1 <slide-button> ;
+: <down-button> ( slider orientation -- button )
+    swap slider-vertical? arrow-down arrow-right ? 1
+    <slide-button> ;
 
-: add-down @{ 1 1 1 }@ over slider-vector v+ first2 frame-add ;
+: add-down @{ 1 1 1 }@ over gadget-orientation v+ first2 frame-add ;
 
 : add-elevator 2dup set-slider-elevator @center frame-add ;
 
 : add-thumb 2dup slider-elevator add-gadget set-slider-thumb ;
 
 : slider-opposite ( slider -- vector )
-    slider-vector @{ 1 1 0 }@ swap v- ;
+    gadget-orientation @{ 1 1 0 }@ swap v- ;
 
 C: slider ( vector -- slider )
-    [ set-slider-vector ] keep
     dup delegate>frame
+    [ set-gadget-orientation ] keep
     0 over set-slider-value
     0 over set-slider-page
     0 over set-slider-max
-    dup slider-opposite <elevator> over add-elevator
-    dup <up-button> over add-up
-    dup <down-button> over add-down
-    dup slider-opposite <thumb> over add-thumb ;
+    dup slider-opposite
+    2dup <elevator> pick add-elevator
+    2dup <up-button> pick add-up
+    2dup <down-button> pick add-down
+    dupd <thumb> pick add-thumb ;
 
 : <x-slider> ( -- slider ) @{ 1 0 0 }@ <slider> ;
 

library/ui/splitters.factor

@@ -17,7 +17,7 @@ TUPLE: splitter split ;
 
 : divider-motion ( splitter -- )
     dup hand>split
-    over rect-dim @{ 1 1 1 }@ vmax v/ over pack-vector v.
+    over rect-dim @{ 1 1 1 }@ vmax v/ over gadget-orientation v.
     0 max 1 min over set-splitter-split relayout-1 ;
 
 : divider-actions ( thumb -- )

library/ui/theme.factor

@@ -7,15 +7,15 @@ USING: arrays gadgets kernel sequences styles ;
     << solid >> interior set-paint-prop ;
 
 : solid-boundary ( gadget -- )
-    << solid f >> boundary set-paint-prop ;
+    << solid >> boundary set-paint-prop ;
 
-: button-theme ( gadget vector -- )
-    dupd @{
+: button-theme ( gadget -- )
+    dup << gradient @{
         @{ 240 240 240 }@
         @{ 192 192 192 }@
         @{ 192 192 192 }@
         @{ 96 96 96 }@
-    }@ <gradient> interior set-paint-prop
+    }@ >> interior set-paint-prop
     dup @{ 96 96 96 }@ foreground set-paint-prop
     << solid >> boundary set-paint-prop ;
 
@@ -30,13 +30,12 @@ USING: arrays gadgets kernel sequences styles ;
     dup solid-interior
     red background set-paint-prop ;
 
-: elevator-theme ( elevator vector -- )
-    dupd @{
-            @{ 64 64 64 }@
-            @{ 96 96 96 }@
-            @{ 128 128 128 }@
-        }@
-    <gradient> interior set-paint-prop
+: elevator-theme ( elevator -- )
+    dup << gradient @{
+        @{ 64 64 64 }@
+        @{ 96 96 96 }@
+        @{ 128 128 128 }@
+    }@ >> interior set-paint-prop
     light-gray background set-paint-prop ;
 
 : divider-theme ( divider -- )
@@ -48,7 +47,7 @@ USING: arrays gadgets kernel sequences styles ;
 
 : menu-theme ( menu -- )
     dup solid-boundary
-    << gradient f @{ 1 0 0 }@ @{ @{ 216 216 216 }@ @{ 255 255 255 }@ }@ >>
+    << gradient f @{ @{ 216 216 216 }@ @{ 255 255 255 }@ }@ >>
     interior set-paint-prop ;
 
 : icon-theme ( gadget -- )