- goal: to compile hash* optimally\r
- type check/not-check entry points for compiled words\r
- getenv/setenv: if literal arg, compile as a load/store\r
+- empty ifte: wrong input type.\r
\r
+ oop:\r
\r
- completion in the listener\r
- special completion for USE:/IN:\r
- support USING:\r
+- command to prettyprint word def at caret, or selection\r
\r
+ i/o:\r
\r
\r
"/library/ui/line-editor.factor"\r
"/library/ui/console.factor"\r
+ "/library/ui/shapes.factor"\r
+ "/library/ui/paint.factor"\r
+ "/library/ui/gadgets.factor"\r
\r
"/library/bootstrap/image.factor"\r
\r
: infer-alien ( -- )
[ object object object object ] ensure-d
- dataflow-drop, pop-d value-literal
- dataflow-drop, pop-d value-literal >r
- dataflow-drop, pop-d value-literal
- dataflow-drop, pop-d value-literal -rot
+ dataflow-drop, pop-d literal-value
+ dataflow-drop, pop-d literal-value >r
+ dataflow-drop, pop-d literal-value
+ dataflow-drop, pop-d literal-value -rot
r> swap alien-node ;
: box-parameter
>r unit [ car tuple-dispatch call ] cons tuple r>
set-vtable ;
+M: tuple clone ( tuple -- tuple )
+ dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
+
+: tuple>list ( tuple -- list )
+ dup array-capacity swap array>list ;
+
+M: tuple = ( obj tuple -- ? )
+ over tuple? [
+ over class over class = [
+ swap tuple>list swap tuple>list =
+ ] [
+ 2drop f
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+M: tuple hashcode ( vec -- n )
+ dup array-capacity 1 number= [
+ drop 0
+ ] [
+ 1 swap array-nth hashcode
+ ] ifte ;
+
M: tuple class ( obj -- class ) 2 slot ;
tuple [
uncons propagate-type
dup value-recursion recursive-state set
copy-inference
- value-literal dup infer-quot
+ literal-value dup infer-quot
#values values-node
handle-terminator
] extend ;
dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
gensym [
dup value-recursion recursive-state set
- value-literal infer-quot
+ literal-value infer-quot
] (with-block) drop ;
: dynamic-ifte ( true false -- )
\ ifte [ infer-ifte ] "infer" set-word-property
: vtable>list ( value -- list )
- dup value-recursion swap value-literal vector>list
+ dup value-recursion swap literal-value vector>list
[ over <literal> ] map nip ;
USE: kernel-internals
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
-! A value has the following slots in addition to those relating
-! to generics above:
+TUPLE: value class type-prop recursion ;
-TUPLE: value literal class type-prop recursion ;
-C: value ;
+C: value ( recursion -- value )
+ [ set-value-recursion ] keep ;
TUPLE: computed delegate ;
C: computed ( class -- value )
- <value> over set-computed-delegate
- [ set-value-class ] keep ;
-
-M: computed value-literal ( value -- obj )
- "Cannot use a computed value literally." throw ;
+ swap recursive-state get <value> [ set-value-class ] keep
+ over set-computed-delegate ;
M: computed value= ( literal value -- ? )
2drop f ;
M: computed value-class-and ( class value -- )
[ value-class class-and ] keep set-value-class ;
-TUPLE: literal delegate ;
+TUPLE: literal value delegate ;
C: literal ( obj rstate -- value )
- <value> over set-literal-delegate
- [ set-value-recursion ] keep
- [ set-value-literal ] keep ;
+ [
+ >r <value> [ >r dup class r> set-value-class ] keep
+ r> set-literal-delegate
+ ] keep
+ [ set-literal-value ] keep ;
M: literal value= ( literal value -- ? )
- value-literal = ;
+ literal-value = ;
M: literal value-class-and ( class value -- )
value-class class-and drop ;
! \ slot [
! [ object fixnum ] ensure-d
-! dataflow-drop, pop-d value-literal
+! dataflow-drop, pop-d literal-value
! peek-d value-class builtin-supertypes dup length 1 = [
! cons \ slot [ [ object ] [ object ] ] (consume/produce)
! ] [
1 0 node-inputs
[ object ] consume-d
[ fixnum ] produce-d
- r> peek-d value-type-prop
+ r> peek-d set-value-type-prop
1 0 node-outputs
] bind
] "infer" set-word-property
M: symbol (apply-word) ( word -- )
apply-literal ;
-: current-word ( -- word )
- #! Push word we're currently inferring effect of.
- recursive-state get car car ;
-
-: check-recursion ( word -- )
- #! If at the location of the recursive call, we're taking
- #! more items from the stack than producing, we have a
- #! diverging recursion. Note that this check is not done for
- #! mutually-recursive words. Generally they should be
- #! avoided.
- current-word = [
- d-in get vector-length
- meta-d get vector-length > [
- current-word word-name " diverges." cat2 throw
- ] when
- ] when ;
-
: with-recursion ( quot -- )
[
inferring-base-case inc
: apply-word ( word -- )
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get assoc [
- dup check-recursion recursive-word
+ recursive-word
] [
dup "infer-effect" word-property [
apply-effect
gensym dup [
drop pop-d dup
value-recursion recursive-state set
- value-literal infer-quot
+ literal-value infer-quot
] with-block drop ;
\ call [ infer-call ] "infer" set-word-property
: 3list ( a b c -- [ a b c ] )
2list cons ;
+: 3unlist ( [ a b c ] -- a b c )
+ uncons uncons car ;
+
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
over [ >r uncons r> append cons ] [ nip ] ifte ;
#! Set up SDL graphics and call the quotation.
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
-: rgb ( r g b a -- n )
+: rgb ( r g b -- n )
255
swap 8 shift bitor
swap 16 shift bitor
"strings"
"namespaces"
"generic"
+ "tuple"
"files"
"parser"
"parse-number"
--- /dev/null
+IN: scratchpad
+USING: generic kernel test math ;
+
+TUPLE: rect x y w h ;
+C: rect
+ [ set-rect-h ] keep
+ [ set-rect-w ] keep
+ [ set-rect-y ] keep
+ [ set-rect-x ] keep ;
+
+: move ( x rect -- )
+ [ rect-x + ] keep set-rect-x ;
+
+[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
+
+[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
+
+
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic hashtables kernel lists namespaces ;
+
+! Gadget protocol.
+GENERIC: pick-up ( point gadget -- gadget )
+
+! A gadget is a shape together with paint, and a reference to
+! the gadget's parent. A gadget delegates to its shape.
+TUPLE: gadget paint parent delegate ;
+
+C: gadget ( shape -- gadget )
+ [ set-gadget-delegate ] keep
+ [ <namespace> swap set-gadget-paint ] keep ;
+
+: paint-property ( gadget key -- value )
+ swap gadget-paint hash ;
+
+: set-paint-property ( gadget value key -- )
+ rot gadget-paint set-hash ;
+
+: with-gadget ( gadget quot -- )
+ #! All drawing done inside the quotation is done with the
+ #! gadget's paint. If the gadget does not have any custom
+ #! paint, just call the quotation.
+ >r gadget-paint r> bind ;
+
+M: gadget draw ( gadget -- )
+ dup [ gadget-delegate draw ] with-gadget ;
+
+M: gadget pick-up tuck inside? [ drop f ] unless ;
+
+! An invisible gadget.
+WRAPPER: ghost
+M: ghost draw drop ;
+M: ghost pick-up 2drop f ;
+
+! A box is a gadget holding other gadgets.
+TUPLE: box contents delegate ;
+
+C: box ( gadget -- box )
+ [ set-box-delegate ] keep ;
+
+M: general-list draw ( list -- )
+ [ draw ] each ;
+
+M: box draw ( box -- )
+ dup [
+ dup [
+ dup box-contents draw
+ box-delegate draw
+ ] with-gadget
+ ] with-translation ;
+
+M: general-list pick-up ( point list -- gadget )
+ dup [
+ 2dup car pick-up dup [
+ 2nip
+ ] [
+ drop cdr pick-up
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+M: box pick-up ( point box -- )
+ #! The logic is thus. If the point is definately outside the
+ #! box, return f. Otherwise, see if the point is contained
+ #! in any subgadget. If not, see if it is contained in the
+ #! box delegate.
+ dup [
+ 2dup gadget-delegate inside? [
+ 2dup box-contents pick-up dup [
+ 2nip
+ ] [
+ drop box-delegate pick-up
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte
+ ] with-translation ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl sdl-gfx ;
+
+! The painting protocol. Painting is controlled by various
+! dynamically-scoped variables.
+
+! "Paint" is a namespace containing some or all of these values.
+SYMBOL: color ! a list of three integers, 0..255.
+SYMBOL: font ! a list of two elements, a font name and size.
+SYMBOL: filled ! is the interior of the shape filled?
+
+: shape>screen ( shape -- x1 y1 x2 y2 )
+ [ shape-x x get + ] keep
+ [ shape-y y get + ] keep
+ [ dup shape-x swap shape-w + x get + ] keep
+ dup shape-y swap shape-h + y get + ;
+
+: rgb-color ( -- rgba ) color get 3unlist rgb ;
+
+GENERIC: draw ( obj -- )
+
+M: rect draw ( rect -- )
+ >r surface get r> shape>screen rgb-color
+ filled get [ boxColor ] [ rectangleColor ] ifte ;
+
+: default-paint ( -- paint )
+ {{
+ [[ x 0 ]]
+ [[ y 0 ]]
+ [[ color [ 0 0 0 ] ]]
+ [[ filled f ]]
+ [[ font [ "Monospaced" 12 ] ]]
+ }} ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel math namespaces ;
+
+! Shape protocol.
+
+! These dynamically-bound variables affect the generic word
+! inside?.
+SYMBOL: x ! x translation
+SYMBOL: y ! y translation
+
+! A shape is an object with a defined bounding
+! box, and a notion of interior.
+GENERIC: shape-x
+GENERIC: shape-y
+GENERIC: shape-w
+GENERIC: shape-h
+
+GENERIC: inside? ( point shape -- ? )
+
+: with-translation ( shape quot -- )
+ #! All drawing done inside the quotation is translated
+ #! relative to the shape's origin.
+ [
+ >r dup
+ shape-x x [ + ] change
+ shape-y y [ + ] change
+ r> call
+ ] with-scope ; inline
+
+! A point, represented as a complex number, is the simplest type
+! of shape.
+M: number shape-x real ;
+M: number shape-y imaginary ;
+M: number shape-w drop 0 ;
+M: number shape-h drop 0 ;
+M: number inside? = ;
+
+! A rectangle maps trivially to the shape protocol.
+TUPLE: rect x y w h ;
+M: rect shape-x rect-x ;
+M: rect shape-y rect-y ;
+M: rect shape-w rect-w ;
+M: rect shape-h rect-h ;
+
+: fix-neg ( a b c -- a+c b -c )
+ dup 0 < [ neg tuck >r >r + r> r> ] when ;
+
+C: rect ( x y w h -- rect )
+ #! We handle negative w/h for convinience.
+ >r fix-neg >r fix-neg r> r>
+ [ set-rect-h ] keep
+ [ set-rect-w ] keep
+ [ set-rect-y ] keep
+ [ set-rect-x ] keep ;
+
+: rect-x-extents ( rect -- x1 x2 )
+ dup rect-x x get + swap rect-w dupd + ;
+
+: rect-y-extents ( rect -- x1 x2 )
+ dup rect-y y get + swap rect-h dupd + ;
+
+M: rect inside? ( point rect -- ? )
+ over real over rect-x-extents between? >r
+ swap imaginary swap rect-y-extents between? r> and ;
projects / factor.git / commitdiff