Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
5487188424
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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 -- )
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
demos
|
||||
games
|
||||
applications
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
|
|||
|
|
@ -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 ] with-ui ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: demos
|
||||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -39,12 +39,20 @@ TUPLE: irc-tab < frame listener client userlist ;
|
|||
|
||||
GENERIC: write-irc ( irc-message -- )
|
||||
|
||||
M: ping write-irc
|
||||
drop "* Ping" blue write-color ;
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
[ prefix>> parse-name write ] keep
|
||||
"> " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
M: notice write-irc
|
||||
[ type>> blue write-color ] keep
|
||||
": " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
TUPLE: own-message message nick timestamp ;
|
||||
|
||||
: <own-message> ( message nick -- own-message )
|
||||
|
|
@ -116,7 +124,7 @@ M: irc-message write-irc
|
|||
|
||||
GENERIC: handle-inbox ( tab message -- )
|
||||
|
||||
: filter-participants ( pack alist val color -- )
|
||||
: filter-participants ( pack alist val color -- pack )
|
||||
'[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
|
||||
|
||||
: update-participants ( tab -- )
|
||||
|
|
@ -124,7 +132,7 @@ GENERIC: handle-inbox ( tab message -- )
|
|||
[ listener>> participants>> ] bi
|
||||
[ +operator+ green filter-participants ]
|
||||
[ +voice+ blue filter-participants ]
|
||||
[ +normal+ black filter-participants ] 2tri ;
|
||||
[ +normal+ black filter-participants ] tri drop ;
|
||||
|
||||
M: participant-changed handle-inbox
|
||||
drop update-participants ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -1,2 +1,3 @@
|
|||
demos
|
||||
games
|
||||
applications
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
demos
|
||||
applications
|
||||
games
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue