: directory-no/ ( -- )
[
- "request" get , CHAR: / ,
- "raw-query" get [ CHAR: ? , , ] when*
+ "request" get % CHAR: / ,
+ "raw-query" get [ CHAR: ? , % ] when*
] make-string redirect ;
: content-length ( alist -- length )
: log-user-agent ( alist -- )
"User-Agent" swap assoc* [
- unswons [ , ": " , , ] make-string log
+ unswons [ % ": " % % ] make-string log
] when* ;
: prepare-url ( url -- url )
duplex-stream-out stream-write-attr ;
M: duplex-stream stream-close
+ #! The output stream is closed first, in case both streams
+ #! are attached to the same file descriptor, the output
+ #! buffer needs to be flushed before we close the fd.
dup
- duplex-stream-in stream-close
- duplex-stream-out stream-close ;
+ duplex-stream-out stream-close
+ duplex-stream-in stream-close ;
M: duplex-stream set-timeout
2dup
vectors ;
: n*v ( n vec -- vec ) [ * ] map-with ;
+: v*n ( vec n -- vec ) swap n*v ;
! Vector operations
: v+ ( v v -- v ) [ + ] 2map ;
: CHAR: ( -- ) 0 scan next-char drop swons ; parsing
! String literal
-: (parse-string) ( n str -- n )
- 2dup nth CHAR: " = [
- drop 1 +
- ] [
- [ next-char swap , ] keep (parse-string)
- ] ifte ;
-
-: parse-string ( -- str )
- #! Read a string from the input stream, until it is
- #! terminated by a ".
- "col" [
- [ "line" get (parse-string) ] make-string swap
- ] change ;
-
: " parse-string swons ; parsing
: SBUF" skip-blank parse-string >sbuf swons ; parsing
] [
drop
] ifte ;
+
+: (parse-string) ( n str -- n )
+ 2dup nth CHAR: " = [
+ drop 1 +
+ ] [
+ [ next-char swap , ] keep (parse-string)
+ ] ifte ;
+
+: parse-string ( -- str )
+ #! Read a string from the input stream, until it is
+ #! terminated by a ".
+ "col" [
+ [ "line" get (parse-string) ] make-string swap
+ ] change ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic hashtables kernel lists math namespaces sequences
-vectors ;
+USING: generic hashtables kernel lists math matrices namespaces
+sequences vectors ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
gadget-children [ prefer ] each ;
GENERIC: user-input* ( ch gadget -- ? )
+
M: gadget user-input* 2drop t ;
+
+GENERIC: orientation ( gadget -- vector )
+
+: orient* ( x y axis -- v )
+ 2dup v* >r >r drop dup r> v* v- r> v+ ;
+
+: orient ( x y gadget -- vec )
+ orientation orient* ;
M: divider pref-size drop 16 16 ;
-TUPLE: splitter vector first divider second ;
+TUPLE: splitter vector first divider second split ;
-C: splitter ( first second vector -- )
+M: splitter orientation splitter-vector ;
+
+C: splitter ( first second vector -- splitter )
+ <empty-gadget> over set-delegate
[ set-splitter-vector ] keep
[ set-splitter-second ] keep
[ set-splitter-first ] keep
- [ dup <divider> swap set-splitter-divider ] keep ;
+ [ dup <divider> swap set-splitter-divider ] keep
+ 1/2 over set-splitter-split ;
+
+: <x-splitter> ( first second -- splitter )
+ { 1 0 0 } <splitter> ;
+
+: <y-splitter> ( first second -- splitter )
+ { 0 1 0 } <splitter> ;
: splitter-pref-dims ( splitter -- dim dim dim )
dup splitter-first pref-dim
over splitter-divider pref-dim
rot splitter-second pref-dim ;
-: set-axis ( x y axis -- v )
- 2dup v* >r >r drop dup r> v* v- r> v+ ;
-
M: splitter pref-size ( splitter -- w h )
[ splitter-pref-dims 3dup vmax vmax >r v+ v+ r> ] keep
- splitter-vector set-axis 3unseq drop ;
+ orient 3unseq drop ;
+
+: size-divider ( splitter -- )
+ dup shape-dim over splitter-divider
+ [ rot orient ] keep set-gadget-dim ;
+
+: move-divider ( splitter -- )
+ [
+ dup shape-dim dup pick splitter-split v*n { 8 8 8 } v-
+ rot orient
+ ] keep splitter-divider set-gadget-loc ;
+
+: layout-divider ( splitter -- )
+ dup size-divider move-divider ;
M: splitter layout* ( splitter -- )
-
- ;
+ ( layout-divider ) drop ;
[ add-center ] keep ;
C: tile ( child caption -- tile )
- [ f line-border swap set-delegate ] keep
+ f line-border over set-delegate
[ >r tile-content r> add-gadget ] keep
- [ tile-actions ] keep ;
+ dup tile-actions ;
M: tile pref-size shape-size ;
: tile ( gadget title -- )
#! Show the gadget in a new tile.
- <tile> [ world get add-gadget ] keep prefer ;
+ <tile> [
+ world get add-gadget { 100 100 0 }
+ ] keep set-gadget-dim ;