From 12590f6c1b583471000137b2176335a701238413 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 31 Jul 2008 23:01:20 -0500
Subject: [PATCH 01/21] Remove unneeded copy
---
unfinished/stack-checker/inlining/inlining.factor | 7 +------
1 file changed, 1 insertion(+), 6 deletions(-)
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 068dbaba02..ffa90c13ed 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -106,17 +106,12 @@ SYMBOL: enter-out
'[ , prepend ] bi@
<effect> ;
-: insert-copy ( effect -- )
- in>> [ consume-d dup ] keep make-copies
- [ nip output-d ] [ #copy, ] 2bi ;
-
: call-recursive-inline-word ( word -- )
dup "recursive" word-prop [
[ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ 2drop insert-copy ]
[ add-call drop ]
[ nip '[ , #call-recursive, ] consume/produce ]
- 3tri
+ 3bi
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
From 01401e2becac32ebe6f6e8557105653006bc90ae Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:22:54 -0500
Subject: [PATCH 02/21] ui.gadgets.slate: Restore glOrtho settings such that
workspace isn't blurry
---
extra/ui/gadgets/slate/slate.factor | 13 ++++++++-----
1 file changed, 8 insertions(+), 5 deletions(-)
diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor
index 08e8b2765c..0505586b53 100644
--- a/extra/ui/gadgets/slate/slate.factor
+++ b/extra/ui/gadgets/slate/slate.factor
@@ -96,18 +96,21 @@ M: slate draw-gadget* ( slate -- )
establish-coordinate-system
- GL_MODELVIEW glMatrixMode glLoadIdentity glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
setup-viewport
draw-slate
- GL_PROJECTION glMatrixMode glPopMatrix
- GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
dup
find-world
- default-coordinate-system
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
setup-viewport
drop
- drop ;
\ No newline at end of file
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From bf2a1d2399ee9e694e49b9739746871f11c7bbfc Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:24:00 -0500
Subject: [PATCH 03/21] golden-section: <golden-section> word
---
extra/golden-section/golden-section.factor | 17 ++++++++---------
1 file changed, 8 insertions(+), 9 deletions(-)
diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor
index 05e7f68d0a..8d1e6b49d6 100644
--- a/extra/golden-section/golden-section.factor
+++ b/extra/golden-section/golden-section.factor
@@ -39,16 +39,15 @@ IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: <golden-section> ( -- gadget )
+ <cartesian>
+ { 600 600 } >>pdim
+ { -400 400 } x-range
+ { -400 400 } y-range
+ [ golden-section ] >>action ;
+
: golden-section-window ( -- )
- [
- <cartesian>
- { 600 600 } >>pdim
- { -400 400 } x-range
- { -400 400 } y-range
- [ golden-section ] >>action
- "Golden Section" open-window
- ]
- with-ui ;
+ [ <golden-section> "Golden Section" open-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 1fcbcef22d7da03673fc3099652b60b34f3d2c1a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 1 Aug 2008 14:28:34 -0500
Subject: [PATCH 04/21] fix unit tests in concurrency several spawned threads
were not labelled
---
basis/concurrency/messaging/messaging-docs.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor
index 1219982f51..6c9e530d9b 100755
--- a/basis/concurrency/messaging/messaging-docs.factor
+++ b/basis/concurrency/messaging/messaging-docs.factor
@@ -56,19 +56,19 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"USING: concurrency.messaging kernel threads ;"
": pong-server ( -- )"
" receive >r \"pong\" r> reply-synchronous ;"
- "[ pong-server t ] spawn-server"
+ "[ pong-server t ] \"pong-server\" spawn-server"
"\"ping\" swap send-synchronous ."
"\"pong\""
} ;
ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
-{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
+{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
{ $subsection spawn-linked }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
-" [ 1 0 / \"This will not print\" print ] spawn-linked drop"
+" [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop"
" receive"
"] [ \"Exception caught.\" print ] recover" }
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
From 2eaef8044d755ddc6da67a85acbf2761bb260710 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 1 Aug 2008 14:29:21 -0500
Subject: [PATCH 05/21] update lint just because
---
unmaintained/lint/lint.factor | 49 ++++++++++++++++++-----------------
1 file changed, 25 insertions(+), 24 deletions(-)
diff --git a/unmaintained/lint/lint.factor b/unmaintained/lint/lint.factor
index dcf52f723a..644346d29e 100644
--- a/unmaintained/lint/lint.factor
+++ b/unmaintained/lint/lint.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
+USING: accessors alien alien.accessors arrays assocs
+combinators.lib io kernel macros math namespaces prettyprint
+quotations sequences vectors vocabs words html.elements sets
+slots.private combinators.short-circuit ;
IN: lint
SYMBOL: def-hash
@@ -18,7 +19,7 @@ SYMBOL: def-hash-keys
2drop
] if ;
-: more-defs
+: more-defs ( -- )
{
{ [ swap >r swap r> ] -rot }
{ [ swap swapd ] -rot }
@@ -33,6 +34,7 @@ SYMBOL: def-hash-keys
{ [ 0 = ] zero? }
{ [ pop drop ] pop* }
{ [ [ ] if ] when }
+ { [ f = not ] >boolean }
} [ first2 swap add-word-def ] each ;
: accessor-words ( -- seq )
@@ -51,33 +53,32 @@ SYMBOL: def-hash-keys
{
[ get ] [ t ] [ { } ] [ . ] [ drop f ]
[ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ <unimplemented-typeflag> throw ]
- [ "/>" write-html ]
+ [ ">" write-html ] [ "/>" write-html ]
} ;
H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
+all-words [ dup def>> add-word-def ] each
more-defs
! Remove empty word defs
def-hash get-global [
drop empty? not
-] assoc-subset
+] assoc-filter
! Remove constants [ 1 ]
[
drop dup length 1 = swap first number? and not
-] assoc-subset
+] assoc-filter
! Remove set-alien-cell, etc.
[
- drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
-] assoc-subset
+ drop [ accessor-words diff ] keep [ length ] bi@ =
+] assoc-filter
! Remove trivial defs
[
drop trivial-defs member? not
-] assoc-subset
+] assoc-filter
! Remove n m shift defs
[
@@ -85,19 +86,19 @@ def-hash get-global [
dup first2 [ number? ] both?
swap third \ shift = and not
] [ drop t ] if
-] assoc-subset
+] assoc-filter
! Remove [ n slot ]
[
drop dup length 2 = [
first2 \ slot = swap number? and not
] [ drop t ] if
-] assoc-subset def-hash set-global
+] assoc-filter def-hash set-global
-: find-duplicates
+: find-duplicates ( -- seq )
def-hash get-global [
nip length 1 >
- ] assoc-subset ;
+ ] assoc-filter ;
def-hash get-global keys def-hash-keys set-global
@@ -107,18 +108,18 @@ M: object lint ( obj -- seq )
drop f ;
: subseq/member? ( subseq/member seq -- ? )
- { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+ { [ start ] [ member? ] } 2|| ;
M: callable lint ( quot -- seq )
def-hash-keys get [
swap subseq/member?
- ] with subset ;
+ ] with filter ;
M: word lint ( word -- seq )
- word-def dup callable? [ lint ] [ drop f ] if ;
+ def>> dup callable? [ lint ] [ drop f ] if ;
: word-path. ( word -- )
- [ word-vocabulary ":" ] keep unparse 3append write nl ;
+ [ vocabulary>> ":" ] keep unparse 3append write nl ;
: (lint.) ( pair -- )
first2 >r word-path. r> [
@@ -135,7 +136,7 @@ M: word lint ( word -- seq )
GENERIC: run-lint ( obj -- obj )
-: (trim-self)
+: (trim-self) ( val key -- obj ? )
def-hash get-global at* [
dupd remove empty? not
] [
@@ -143,13 +144,13 @@ GENERIC: run-lint ( obj -- obj )
] if ;
: trim-self ( seq -- newseq )
- [ [ (trim-self) ] subset ] assoc-map ;
+ [ [ (trim-self) ] filter ] assoc-map ;
: filter-symbols ( alist -- alist )
[
nip first dup def-hash get at
[ first ] bi@ literalize = not
- ] assoc-subset ;
+ ] assoc-filter ;
M: sequence run-lint ( seq -- seq )
[
@@ -157,7 +158,7 @@ M: sequence run-lint ( seq -- seq )
dup lint
] { } map>assoc
trim-self
- [ second empty? not ] subset
+ [ second empty? not ] filter
filter-symbols ;
M: word run-lint ( word -- seq )
From 011a63a27ee9d76e558c1d0215ad8888b7a72d2c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:29:48 -0500
Subject: [PATCH 06/21] prettyprint.backend: Use color objects
---
basis/prettyprint/backend/backend.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 00b38ae4f8..111bcfdafc 100755
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -5,7 +5,7 @@ hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
-combinators ;
+combinators colors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@@ -89,7 +89,7 @@ M: f pprint* drop \ f pprint-word ;
: string-style ( obj -- hash )
[
presented set
- { 0.3 0.3 0.3 1.0 } foreground set
+ T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
] H{ } make-assoc ;
: unparse-string ( str prefix suffix -- str )
From 4deed7b44a6757cc7ae677ce6dae56048f98bf97 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:32:47 -0500
Subject: [PATCH 07/21] help.stylesheet: Use color objects
---
basis/help/stylesheet/stylesheet.factor | 18 +++++++++---------
1 file changed, 9 insertions(+), 9 deletions(-)
diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor
index 68810e2369..50357db8cf 100755
--- a/basis/help/stylesheet/stylesheet.factor
+++ b/basis/help/stylesheet/stylesheet.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.styles namespaces ;
+USING: io.styles namespaces colors ;
IN: help.stylesheet
SYMBOL: default-span-style
@@ -17,7 +17,7 @@ H{
SYMBOL: link-style
H{
- { foreground { 0 0 0.3 1 } }
+ { foreground T{ rgba f 0 0 0.3 1 } }
{ font-style bold }
} link-style set-global
@@ -33,7 +33,7 @@ H{
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
- { page-color { 0.8 0.8 0.8 1 } }
+ { page-color T{ rgba f 0.8 0.8 0.8 1 } }
{ border-width 5 }
} title-style set-global
@@ -58,12 +58,12 @@ SYMBOL: snippet-style
H{
{ font "monospace" }
{ font-size 12 }
- { foreground { 0.1 0.1 0.4 1 } }
+ { foreground T{ rgba f 0.1 0.1 0.4 1 } }
} snippet-style set-global
SYMBOL: code-style
H{
- { page-color { 0.8 0.8 0.8 0.5 } }
+ { page-color T{ rgba f 0.8 0.8 0.8 0.5 } }
{ border-width 5 }
{ wrap-margin f }
} code-style set-global
@@ -74,13 +74,13 @@ H{ { font-style bold } } input-style set-global
SYMBOL: url-style
H{
{ font "monospace" }
- { foreground { 0.0 0.0 1.0 1.0 } }
+ { foreground T{ rgba f 0.0 0.0 1.0 1.0 } }
} url-style set-global
SYMBOL: warning-style
H{
- { page-color { 0.95 0.95 0.95 1 } }
- { border-color { 1 0 0 1 } }
+ { page-color T{ rgba f 0.95 0.95 0.95 1 } }
+ { border-color T{ rgba f 1 0 0 1 } }
{ border-width 5 }
{ wrap-margin 500 }
} warning-style set-global
@@ -93,7 +93,7 @@ H{
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
- { table-border { 0.8 0.8 0.8 1.0 } }
+ { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
} table-style set-global
SYMBOL: list-style
From 694de3fb70b9259f0b3d534fd098118f07a6defa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:33:20 -0500
Subject: [PATCH 08/21] listener: Use color objects
---
basis/listener/listener.factor | 5 +++--
extra/colors/colors.factor | 2 +-
2 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 5ff5830e7a..feddbdc042 100755
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -3,7 +3,8 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
-definitions compiler.units accessors ;
+definitions compiler.units accessors colors ;
+
IN: listener
SYMBOL: quit-flag
@@ -41,7 +42,7 @@ M: object stream-read-quot
: prompt. ( -- )
"( " in get " )" 3append
- H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
+ H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: error-hook
diff --git a/extra/colors/colors.factor b/extra/colors/colors.factor
index ae3695cf8b..f88fe6eb05 100644
--- a/extra/colors/colors.factor
+++ b/extra/colors/colors.factor
@@ -27,7 +27,7 @@ M: hsva >rgba ( hsva -- rgba )
M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-M: array >rgba ( array -- rgba ) first4 rgba boa ;
+! M: array >rgba ( array -- rgba ) first4 rgba boa ;
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
From f33039f2d1a94e1b535b6a81c37418ef7fc1fad2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:34:19 -0500
Subject: [PATCH 09/21] colors: Remove the '>rgba' method on array (was a
kludge).
---
extra/colors/colors.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/colors/colors.factor b/extra/colors/colors.factor
index f88fe6eb05..77a1f46c87 100644
--- a/extra/colors/colors.factor
+++ b/extra/colors/colors.factor
@@ -27,8 +27,6 @@ M: hsva >rgba ( hsva -- rgba )
M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-! M: array >rgba ( array -- rgba ) first4 rgba boa ;
-
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
From 2401301927df4b8ec992c731debe407e0a33a712 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 14:59:53 -0500
Subject: [PATCH 10/21] Remove 'processing.color' (evolved into colors)
---
extra/processing/color/color.factor | 22 ----------------------
1 file changed, 22 deletions(-)
delete mode 100644 extra/processing/color/color.factor
diff --git a/extra/processing/color/color.factor b/extra/processing/color/color.factor
deleted file mode 100644
index 50d20fcf52..0000000000
--- a/extra/processing/color/color.factor
+++ /dev/null
@@ -1,22 +0,0 @@
-
-USING: kernel sequences ;
-
-IN: processing.color
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: rgba red green blue alpha ;
-
-C: <rgba> rgba
-
-: <rgb> ( r g b -- rgba ) 1 <rgba> ;
-
-: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
-
-: {rgb} ( seq -- rgba ) first3 <rgb> ;
-
-! : hex>rgba ( hex -- rgba )
-
-! : set-gl-color ( color -- )
-! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
-
From 7e7653eaff84b3985006602a54a3f0430935a6dc Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 15:11:42 -0500
Subject: [PATCH 11/21] io.styles: Use color objects
---
basis/io/styles/styles.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 14827dc7a6..4f0b3ce7e1 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -33,7 +33,7 @@ SYMBOL: table-border
: standard-table-style ( -- style )
H{
{ table-gap { 5 5 } }
- { table-border { 0.8 0.8 0.8 1.0 } }
+ { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
} ;
! Input history
From 4417a647130c419e121e5d9aee2ed61ac1d13ef1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 15:12:03 -0500
Subject: [PATCH 12/21] io.styles: Minor tweak
---
basis/io/styles/styles.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 4f0b3ce7e1..752f413458 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -1,6 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io ;
+
+USING: hashtables io colors ;
+
IN: io.styles
SYMBOL: plain
From 0763124bb948af01280bd094da9e1dc81b153506 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 15:47:35 -0500
Subject: [PATCH 13/21] cfdg: Use color objects and 'self.slots'
---
extra/cfdg/cfdg.factor | 74 ++++++++++++++----------------------------
1 file changed, 25 insertions(+), 49 deletions(-)
diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor
index 2dfa7fae8f..d821b7c180 100644
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@@ -3,40 +3,16 @@ USING: kernel alien.c-types combinators namespaces arrays
sequences sequences.lib namespaces.lib splitting
math math.functions math.vectors math.trig
opengl.gl opengl.glu opengl ui ui.gadgets.slate
- vars
- random-weighted colors.hsv cfdg.gl ;
+ vars colors self self.slots
+ random-weighted colors.hsv cfdg.gl accessors ;
IN: cfdg
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! hsba { hue saturation brightness alpha }
+SELF-SLOTS: hsva
-: <hsba> 4array ;
-
-VAR: color
-
-! ( -- val )
-
-: hue>> 0 color> nth ;
-: saturation>> 1 color> nth ;
-: brightness>> 2 color> nth ;
-: alpha>> 3 color> nth ;
-
-! ( val -- )
-
-: >>hue 0 color> set-nth ;
-: >>saturation 1 color> set-nth ;
-: >>brightness 2 color> set-nth ;
-: >>alpha 3 color> set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
-
-: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
-
-: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ;
+: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -50,18 +26,18 @@ VAR: color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: hue ( num -- ) hue>> + 360 mod >>hue ;
+: hue ( num -- ) hue-> + 360 mod ->hue ;
-: saturation ( num -- ) saturation>> swap adjust >>saturation ;
-: brightness ( num -- ) brightness>> swap adjust >>brightness ;
-: alpha ( num -- ) alpha>> swap adjust >>alpha ;
+: saturation ( num -- ) saturation-> swap adjust ->saturation ;
+: brightness ( num -- ) value-> swap adjust ->value ;
+: alpha ( num -- ) alpha-> swap adjust ->alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: h hue ;
-: sat saturation ;
-: b brightness ;
-: a alpha ;
+: h ( num -- ) hue ;
+: sat ( num -- ) saturation ;
+: b ( num -- ) brightness ;
+: a ( num -- ) alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -69,9 +45,9 @@ VAR: color-stack
: init-color-stack ( -- ) V{ } clone >color-stack ;
-: push-color ( -- ) color> color-stack> push color> clone >color ;
+: push-color ( -- ) self> color-stack> push self> clone >self ;
-: pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ;
+: pop-color ( -- ) color-stack> pop dup >self set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -102,11 +78,11 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
- color> gl-set-hsba
+ self> set-color
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
- color> gl-set-hsba
+ self> set-color
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
@@ -114,7 +90,7 @@ VAR: threshold
glEnd ;
: square ( -- )
- color> gl-set-hsba
+ self> set-color
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
@@ -138,10 +114,10 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: s size ;
-: s* size* ;
-: r rotate ;
-: f flip ;
+: s ( scale -- ) size ;
+: s* ( scale-x scale-y -- ) size* ;
+: r ( angle -- ) rotate ;
+: f ( angle -- ) flip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -162,12 +138,12 @@ VAR: threshold
VAR: background
-: set-initial-background ( -- ) { 0 0 1 1 } clone >color ;
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
: set-background ( -- )
set-initial-background
background> call
- color> gl-clear-hsba ;
+ self> clear-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -177,7 +153,7 @@ VAR: viewport ! { left width bottom height }
VAR: start-shape
-: set-initial-color ( -- ) { 0 0 0 1 } clone >color ;
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
: display ( -- )
@@ -198,7 +174,7 @@ VAR: start-shape
set-initial-color
- color> gl-set-hsba
+ self> set-color
start-shape> call ;
From 438fd22bd36a4170ab03a0c9e3af8916d2e29cb6 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 17:15:44 -0500
Subject: [PATCH 14/21] color-picker: Use color objects
---
extra/color-picker/color-picker.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index c3214f5bf2..5400a12f89 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -4,7 +4,7 @@ USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render math.geometry.rect accessors
- ui.gadgets.grids ;
+ ui.gadgets.grids colors ;
IN: color-picker
! Simple example demonstrating the use of models.
@@ -23,7 +23,7 @@ M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
+ [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
From 3073ab62d6284539ae2fba1ee782236a3d9bfd35 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 17:16:50 -0500
Subject: [PATCH 15/21] automata: Edit tags
---
extra/automata/ui/tags.txt | 1 +
1 file changed, 1 insertion(+)
create mode 100644 extra/automata/ui/tags.txt
diff --git a/extra/automata/ui/tags.txt b/extra/automata/ui/tags.txt
new file mode 100644
index 0000000000..cb5fc203e1
--- /dev/null
+++ b/extra/automata/ui/tags.txt
@@ -0,0 +1 @@
+demos
From 9bd8e88318902e62c09fda13ab31e053b1db1512 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 Aug 2008 17:22:58 -0500
Subject: [PATCH 16/21] Minor improvement to xor word
---
core/kernel/kernel-docs.factor | 2 +-
core/kernel/kernel-tests.factor | 4 ++++
core/kernel/kernel.factor | 2 +-
3 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 3d210e0000..0a1a3cb7f2 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -437,7 +437,7 @@ HELP: or
HELP: xor
{ $values { "obj1" "a generalized boolean" } { "obj2" "a generalized boolean" } { "?" "a generalized boolean" } }
-{ $description "Tests if at exactly one object is not " { $link f } "." }
+{ $description "If exactly one input is false, outputs the other input. Otherwise outputs " { $link f } "." }
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 195e9becae..5cb4abc2e9 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -50,6 +50,10 @@ IN: kernel.tests
[ f ] [ 3 f and ] unit-test
[ 4 ] [ 4 6 or ] unit-test
[ 6 ] [ f 6 or ] unit-test
+[ f ] [ 1 2 xor ] unit-test
+[ 1 ] [ 1 f xor ] unit-test
+[ 2 ] [ f 2 xor ] unit-test
+[ f ] [ f f xor ] unit-test
[ slip ] must-fail
[ ] [ :c ] unit-test
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 47e0d76bf7..337fe6c8b0 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -173,7 +173,7 @@ GENERIC: boa ( ... class -- tuple )
: or ( obj1 obj2 -- ? ) dupd ? ; inline
-: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
+: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
: both? ( x y quot -- ? ) bi@ and ; inline
From a2f6c6dfde40cdfbc4e3b586a28130d321f39ade Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 17:32:30 -0500
Subject: [PATCH 17/21] prettyprint: Use color objects
---
basis/prettyprint/prettyprint.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 4b5dd8542d..f78d12a310 100755
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: prettyprint
+
USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
@@ -8,7 +8,9 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
-combinators quotations sets accessors ;
+combinators quotations sets accessors colors ;
+
+IN: prettyprint
: make-pprint ( obj quot -- block in use )
[
@@ -95,7 +97,7 @@ combinators quotations sets accessors ;
SYMBOL: ->
\ ->
-{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
+{ { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
"word-style" set-word-prop
: remove-step-into ( word -- )
From 90d6948e9d32dc46df2991db048b31b710ca8938 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 17:43:05 -0500
Subject: [PATCH 18/21] Add demo launcher
---
extra/demos/demos.factor | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
create mode 100644 extra/demos/demos.factor
diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor
new file mode 100644
index 0000000000..ba906fc08b
--- /dev/null
+++ b/extra/demos/demos.factor
@@ -0,0 +1,22 @@
+
+USING: kernel fry sequences
+ vocabs.loader tools.vocabs.browser
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
+ ui.tools.listener
+ accessors ;
+
+IN: demos
+
+: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
+
+: <run-vocab-button> ( vocab-name -- button )
+ dup '[ drop [ , run ] call-listener ] <bevel-button> ;
+
+: <demo-runner> ( -- gadget )
+ <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
+
+: demos ( -- ) <demo-runner> <scroller> "Demos" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: demos
\ No newline at end of file
From 6bc363b08d039266247ee899f025fba257a8140d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 17:43:41 -0500
Subject: [PATCH 19/21] Edit some demo tags
---
extra/boids/tags.txt | 1 -
extra/{automata => boids/ui}/tags.txt | 0
2 files changed, 1 deletion(-)
delete mode 100644 extra/boids/tags.txt
rename extra/{automata => boids/ui}/tags.txt (100%)
diff --git a/extra/boids/tags.txt b/extra/boids/tags.txt
deleted file mode 100644
index cb5fc203e1..0000000000
--- a/extra/boids/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-demos
diff --git a/extra/automata/tags.txt b/extra/boids/ui/tags.txt
similarity index 100%
rename from extra/automata/tags.txt
rename to extra/boids/ui/tags.txt
From 5c332525afc6485f156f97512ed84454cf418baa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 18:06:24 -0500
Subject: [PATCH 20/21] demos: Add 'with-ui' call
---
extra/demos/demos.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor
index ba906fc08b..c8e5a35f9e 100644
--- a/extra/demos/demos.factor
+++ b/extra/demos/demos.factor
@@ -15,7 +15,7 @@ IN: demos
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-: demos ( -- ) <demo-runner> <scroller> "Demos" open-window ;
+: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 0430e17241e86f187fbe92951e32ceea15be1c50 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 1 Aug 2008 18:06:46 -0500
Subject: [PATCH 21/21] Add a bunch of demos tags
---
extra/balloon-bomber/tags.txt | 1 +
extra/space-invaders/tags.txt | 1 +
extra/tetris/tags.txt | 1 +
3 files changed, 3 insertions(+)
diff --git a/extra/balloon-bomber/tags.txt b/extra/balloon-bomber/tags.txt
index 4717ffd987..dfed6b33f2 100644
--- a/extra/balloon-bomber/tags.txt
+++ b/extra/balloon-bomber/tags.txt
@@ -1,2 +1,3 @@
+demos
games
applications
diff --git a/extra/space-invaders/tags.txt b/extra/space-invaders/tags.txt
index 4717ffd987..dfed6b33f2 100644
--- a/extra/space-invaders/tags.txt
+++ b/extra/space-invaders/tags.txt
@@ -1,2 +1,3 @@
+demos
games
applications
diff --git a/extra/tetris/tags.txt b/extra/tetris/tags.txt
index 8ae5957a4b..09934571b3 100644
--- a/extra/tetris/tags.txt
+++ b/extra/tetris/tags.txt
@@ -1,2 +1,3 @@
+demos
applications
games