<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>
+0.79:\r
+\r
+- fix remaining cosmetic issues in UI\r
+- investigate UI on Linux/x86\r
+- swap @{ and { syntax\r
+- get stuff in examples dir running in the ui\r
+- [ ... is annoying\r
+ perhaps on the last line of output, if a block doesn't fit, print\r
+ it anyway?\r
+- apropos: use new smarter completion?\r
+\r
+ ui:\r
\r
+- keyboard completion\r
- get outliner working with lots of lines of output\r
- listener continuations\r
- fix up the min thumb size hack\r
- find out why so many small bignums get consed\r
- use incremental strategy for all pack layouts where possible\r
- multiline editing in listener\r
-- get stuff in examples dir running in the ui\r
- text selection\r
- clipboard support\r
\r
+ misc\r
\r
- code walker & exceptions\r
-- load all sources in stage1\r
- investigate if rehashing on startup is really necessary\r
- remove word transfer hack in bootstrap\r
-- [ ... is annoying\r
- perhaps on the last line of output, if a block doesn't fit, print\r
- it anyway?\r
-- apropos: use new smarter completion?\r
- signal handler should not lose stack pointers\r
-- http keep alive, and range get\r
\r
+ ffi:\r
\r
- slice: if sequence or seq start is changed, abstraction violation\r
- split: return vectors\r
- set-path: iterative\r
-- swap @{ }@ and { } syntax\r
- specialized arrays\r
- instances: do not use make-list\r
- >c/c>: vector stack\r
- 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
- 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)
- 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/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
--- /dev/null
+IN: temporary
+USING: html io kernel namespaces styles test ;
+
+[
+ "<html>&'sgml'"
+] [ "<html>&'sgml'" chars>entities ] unit-test
+
+[ "/foo/bar" ]
+[
+ [
+ "/home/slava/doc/" "doc-root" set
+ "/home/slava/doc/foo/bar" file-link-href
+ ] with-scope
+] unit-test
+
+[ "" ]
+[
+ [
+ [ ] [ drop ] span-tag
+ ] string-out
+] unit-test
+
+[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
+[
+ [
+ [ [ foreground 255 0 255 ] [[ font "Monospaced" ]] ]
+ [ drop "car" write ]
+ span-tag
+ ] string-out
+] unit-test
+
+: html-format ( string style -- string )
+ [ format ] with-html-stream ;
+
+[ "hello world" ]
+[
+ [ "hello world" [ ] html-format ] string-out
+] unit-test
+
+[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
+[
+ [
+ "car"
+ [ [ foreground 255 0 255 ] [[ font "Monospaced" ]] ]
+ html-format
+ ] string-out
+] unit-test
+
+[
+ "<html><head><title>Foo</title></head><body><h1>Foo</h1></body></html>"
+] [
+ [
+ "Foo" [ ] html-document
+ ] string-out
+] unit-test
+
+[
+ "<html><head><title>Foo</title></head><body><h1>Foo</h1><pre>Hi</pre></body></html>"
+] [
+ [
+ "Foo" [ "Hi" write ] simple-html-document
+ ] string-out
+] unit-test
--- /dev/null
+USING: http-client test ;
+[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
+[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
+[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
+[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
+[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
+[ 404 ] [ "404 File not found" parse-response ] unit-test
+[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
+[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
--- /dev/null
+IN: temporary
+USE: file-responder
+USE: http
+USE: httpd
+USE: namespaces
+USE: io
+USE: test
+USE: strings
+USE: lists
+
+[ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n\n" ]
+[
+ [ "text/html" 12 file-response ] string-out
+] unit-test
+
+[
+ [
+ [[ "X-Spyware-Requested" "yes" ]]
+ [[ "User-Agent" "Internet Explorer 0.4alpha" ]]
+ ]
+]
+[
+ [ [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ]
+ "X-Spyware-Requested: yes" header-line
+] unit-test
+
+[ ] [ "404 not found" httpd-error ] unit-test
+
+[ "arg" ] [
+ [
+ "arg" "default-argument" set
+ "" responder-argument
+ ] with-scope
+] unit-test
+
+[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
+
+[ ] [
+ "unit/test" log-responder
+] unit-test
+
+[ "index.html" ]
+[ "http://www.jedit.org/index.html" url>path ] unit-test
+
+[ "foo/bar" ]
+[ "http://www.jedit.org/foo/bar" url>path ] unit-test
+
+[ "" ]
+[ "http://www.jedit.org/" url>path ] unit-test
+
+[ "" ]
+[ "http://www.jedit.org" url>path ] unit-test
+
+[ "foobar" ]
+[ "foobar" secure-path ] unit-test
+
+[ f ]
+[ "foobar/../baz" secure-path ] unit-test
+
+[ ] [ "GET ../index.html" parse-request ] unit-test
+[ ] [ "POO" parse-request ] unit-test
+
+[ [ [[ "Foo" "Bar" ]] ] ] [ "Foo=Bar" query>alist ] unit-test
+
+[ [ [[ "Foo" "Bar" ]] [[ "Baz" "Quux" ]] ] ]
+[ "Foo=Bar&Baz=Quux" query>alist ] unit-test
+
+[ [ [[ "Baz" " " ]] ] ]
+[ "Baz=%20" query>alist ] unit-test
+
+[ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test
--- /dev/null
+IN: temporary
+USE: http
+USE: test
+
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world" ] [ "hello+world" url-decode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ " ! " ] [ "%20%21%20" url-decode ] unit-test
+[ "hello world" ] [ "hello world%" url-decode ] unit-test
+[ "hello world" ] [ "hello world%x" url-decode ] unit-test
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "%20%21%20" ] [ " ! " url-encode ] unit-test
\r
: <underline> ( -- gadget )\r
<gadget>\r
- dup << gradient f @{ 1 0 0 }@ @{ @{ 64 64 64 }@ @{ 255 255 255 }@ }@ >>\r
+ dup << gradient f @{ @{ 64 64 64 }@ @{ 255 255 255 }@ }@ >>\r
interior set-paint-prop\r
@{ 0 10 0 }@ over set-gadget-dim ;\r
\r
\r
: tutorial-theme\r
dup @{ 204 204 255 }@ background set-paint-prop\r
- dup << gradient f @{ 0 1 0 }@ @{ @{ 204 204 255 }@ @{ 255 204 255 }@ }@ >>\r
+ dup << gradient f @{ @{ 204 204 255 }@ @{ 255 204 255 }@ }@ >>\r
interior set-paint-prop\r
dup "Sans Serif" font set-paint-prop\r
16 font-size set-paint-prop ;\r
+++ /dev/null
-IN: temporary
-USING: html io kernel namespaces styles test ;
-
-[
- "<html>&'sgml'"
-] [ "<html>&'sgml'" chars>entities ] unit-test
-
-[ "/foo/bar" ]
-[
- [
- "/home/slava/doc/" "doc-root" set
- "/home/slava/doc/foo/bar" file-link-href
- ] with-scope
-] unit-test
-
-[ "" ]
-[
- [
- [ ] [ drop ] span-tag
- ] string-out
-] unit-test
-
-[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
-[
- [
- [ [ foreground 255 0 255 ] [[ font "Monospaced" ]] ]
- [ drop "car" write ]
- span-tag
- ] string-out
-] unit-test
-
-: html-format ( string style -- string )
- [ format ] with-html-stream ;
-
-[ "hello world" ]
-[
- [ "hello world" [ ] html-format ] string-out
-] unit-test
-
-[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
-[
- [
- "car"
- [ [ foreground 255 0 255 ] [[ font "Monospaced" ]] ]
- html-format
- ] string-out
-] unit-test
-
-[
- "<html><head><title>Foo</title></head><body><h1>Foo</h1></body></html>"
-] [
- [
- "Foo" [ ] html-document
- ] string-out
-] unit-test
-
-[
- "<html><head><title>Foo</title></head><body><h1>Foo</h1><pre>Hi</pre></body></html>"
-] [
- [
- "Foo" [ "Hi" write ] simple-html-document
- ] string-out
-] unit-test
+++ /dev/null
-USING: http-client test ;
-[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
-[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
-[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
-[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
-[ 404 ] [ "404 File not found" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
+++ /dev/null
-IN: temporary
-USE: file-responder
-USE: http
-USE: httpd
-USE: namespaces
-USE: io
-USE: test
-USE: strings
-USE: lists
-
-[ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n\n" ]
-[
- [ "text/html" 12 file-response ] string-out
-] unit-test
-
-[
- [
- [[ "X-Spyware-Requested" "yes" ]]
- [[ "User-Agent" "Internet Explorer 0.4alpha" ]]
- ]
-]
-[
- [ [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ]
- "X-Spyware-Requested: yes" header-line
-] unit-test
-
-[ ] [ "404 not found" httpd-error ] unit-test
-
-[ "arg" ] [
- [
- "arg" "default-argument" set
- "" responder-argument
- ] with-scope
-] unit-test
-
-[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
-
-[ ] [
- "unit/test" log-responder
-] unit-test
-
-[ "index.html" ]
-[ "http://www.jedit.org/index.html" url>path ] unit-test
-
-[ "foo/bar" ]
-[ "http://www.jedit.org/foo/bar" url>path ] unit-test
-
-[ "" ]
-[ "http://www.jedit.org/" url>path ] unit-test
-
-[ "" ]
-[ "http://www.jedit.org" url>path ] unit-test
-
-[ "foobar" ]
-[ "foobar" secure-path ] unit-test
-
-[ f ]
-[ "foobar/../baz" secure-path ] unit-test
-
-[ ] [ "GET ../index.html" parse-request ] unit-test
-[ ] [ "POO" parse-request ] unit-test
-
-[ [ [[ "Foo" "Bar" ]] ] ] [ "Foo=Bar" query>alist ] unit-test
-
-[ [ [[ "Foo" "Bar" ]] [[ "Baz" "Quux" ]] ] ]
-[ "Foo=Bar&Baz=Quux" query>alist ] unit-test
-
-[ [ [[ "Baz" " " ]] ] ]
-[ "Baz=%20" query>alist ] unit-test
-
-[ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test
+++ /dev/null
-IN: temporary
-USE: http
-USE: test
-
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
-[ "" ] [ "%XX%XX%X" url-decode ] unit-test
-
-[ "hello world" ] [ "hello+world" url-decode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ " ! " ] [ "%20%21%20" url-decode ] unit-test
-[ "hello world" ] [ "hello world%" url-decode ] unit-test
-[ "hello world" ] [ "hello world%x" url-decode ] unit-test
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "%20%21%20" ] [ " ! " url-encode ] unit-test
"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"
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 ;
! 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? ;
: 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 ;
! 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 ;
[
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 -- )
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 ;
#! 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 ;
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 ;
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
[ 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 -- )
: 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 -- )
: 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 ;
#! 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 * ;
[ 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* ;
[ 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.
: 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 ;
[ 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 ;
: 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 -- )
: 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> ;
: 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 -- )
<< 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 ;
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 -- )
: 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 -- )
projects / factor.git / commitdiff