steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-08-01 17:21:53 -05:00
parent 12590f6c1b 3073ab62d6
commit 8e58db1514
11 changed files with 62 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/help/stylesheet/stylesheet.factor
View File

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

6
basis/io/styles/styles.factor
View File

@ -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
@ -33,7 +35,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

5
basis/listener/listener.factor
View File

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

4
basis/prettyprint/backend/backend.factor
View File

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

1
extra/automata/ui/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

74
extra/cfdg/cfdg.factor
View File

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

4
extra/color-picker/color-picker.factor
View File

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

2
extra/colors/colors.factor
View File

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

17
extra/golden-section/golden-section.factor
View File

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

22
extra/processing/color/color.factor
View File

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

13
extra/ui/gadgets/slate/slate.factor
View File

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