++ ui:\r
+\r
+- if gadgets are moved, added or deleted, update hand.\r
+\r
+ compiler:\r
\r
- type inference fails with some assembler words;\r
- make see work with union, builtin, predicate\r
- doc comments of generics\r
- proper ordering for classes\r
-- tuples: in/out syntax\r
- tuples: gracefully handle changing shape\r
- keep a list of getter/setter words\r
- default constructor\r
{
next = reader.next(false,false);
if(next == FactorScanner.EOF)
+ {
reader.getScanner().error("Expected ;");
- if(next.equals(";"))
+ break;
+ }
+ else if(next.equals(";"))
break;
else if(next instanceof String)
{
USING: words parser kernel namespaces lists strings
kernel-internals math hashtables errors ;
-: make-tuple ( class -- )
+: make-tuple ( class -- tuple )
dup "tuple-size" word-property <tuple>
[ 0 swap set-array-nth ] keep ;
+: (literal-tuple) ( list size -- tuple )
+ dup <tuple> swap [
+ ( list tuple n -- list tuple n )
+ pick car pick pick swap set-array-nth
+ >r >r cdr r> r>
+ ] repeat nip ;
+
+: literal-tuple ( list -- tuple )
+ dup car "tuple-size" word-property over length over = [
+ (literal-tuple)
+ ] [
+ "Incorrect tuple length" throw
+ ] ifte ;
+
+: tuple>list ( tuple -- list )
+ >tuple array>list ;
+
: define-tuple-generic ( tuple word def -- )
over >r [ single-combination ] \ GENERIC: r> define-generic
define-method ;
#! call it directly.
vector-array array-nth call ;
-BUILTIN: tuple 18
+IN: generic BUILTIN: tuple 18
IN: kernel
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2004, 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+! See http://factor.sf.net/license.txt for BSD license.
! Bootstrapping trick; see doc/bootstrap.txt.
IN: !syntax
-USE: syntax
-
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
-USE: unparser
+USING: syntax errors generic hashtables kernel lists
+math namespaces parser strings words vectors unparse ;
: parsing ( -- )
#! Mark the most recently defined word to execute at parse
: {{ f ; parsing
: }} alist>hash swons ; parsing
+! Tuples.
+: << f ; parsing
+: >> reverse literal-tuple swons ; parsing
+
! Complex numbers
: #{ f ; parsing
: }# 2unlist swap rect> swons ; parsing
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2003, 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
-USE: errors
-USE: generic
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: stdio
-USE: strings
-USE: presentation
-USE: unparser
-USE: vectors
-USE: words
-USE: hashtables
+USING: errors generic kernel lists math namespaces stdio strings
+presentation unparser vectors words hashtables ;
SYMBOL: prettyprint-limit
swap prettyprint-{{ swap prettyprint-list prettyprint-}}
] ifte ;
+M: tuple prettyprint* ( indent tuple -- indent )
+ \ << prettyprint*
+ " " write
+ tuple>list [ prettyprint-element ] each
+ \ >> prettyprint* ;
+
: prettyprint-1 ( obj -- )
0 swap prettyprint* drop ;
: button-released ( button -- )
dup t bevel-up? set-paint-property redraw ;
+: mouse-over? ( gadget -- ? ) my-hand hand-gadget child? ;
+
+: rollover-update ( button -- )
+ dup mouse-over? blue black ? foreground set-paint-property ;
+
+: button-pressed? ( button -- ? )
+ dup mouse-over? [
+ my-hand hand-buttons 1 swap contains? [
+ my-hand hand-clicked child?
+ ] [
+ drop f
+ ] ifte
+ ] [
+ drop f
+ ] ifte ;
+
+: bevel-update ( button -- )
+ dup button-pressed? not bevel-up? set-paint-property ;
+
+: button-update ( button -- )
+ dup rollover-update dup bevel-update redraw ;
+
+: button-clicked ( button -- )
+ #! If the mouse is released while still inside the button,
+ #! fire an action gesture.
+ dup button-update
+ dup mouse-over? [
+ [ action ] swap handle-gesture
+ ] [
+ drop
+ ] ifte ;
+
+: button-actions ( button quot -- )
+ dupd [ action ] set-action
+ dup [ button-clicked ] [ button-up 1 ] set-action
+ dup [ button-update ] [ button-down 1 ] set-action
+ dup [ button-update ] [ mouse-leave ] set-action
+ dup [ button-update ] [ mouse-enter ] set-action ;
+
: <button> ( label quot -- button )
- >r <label> bevel-border
- dup [ dup button-released ] r> append
- [ button-up 1 ] set-action
- dup [ button-pressed ]
- [ button-down 1 ] set-action
- dup [ USE: prettyprint . "Mouse left" USE: stdio print ]
- [ mouse-leave ] set-action
- dup [ USE: prettyprint . "Mouse enter" USE: stdio print ]
- [ mouse-enter ] set-action ;
+ >r <label> bevel-border dup r> button-actions ;
+
+: <check-box> ( label quot -- checkbox )
+ >r 0 0 0 0 <rectangle> <shelf>
+ [ >r <label> r> add-gadget ] keep
+ [ >r f bevel-border r> add-gadget ] keep dup
+ r> button-actions ;
: screen-pos ( gadget -- point )
#! The position of the gadget on the screen.
0 swap [ shape-pos + t ] each-parent ;
+
+: child? ( parent child -- ? )
+ dup [
+ 2dup eq? [ 2drop t ] [ gadget-parent child? ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
: button\ ( n hand -- )
[ hand-buttons remove ] keep set-hand-buttons ;
-: fire-leave ( hand -- )
- dup hand-gadget [ swap shape-pos swap screen-pos - ] keep
- mouse-leave ;
+: fire-leave ( hand gadget -- )
+ [ swap shape-pos swap screen-pos - ] keep mouse-leave ;
: fire-enter ( oldpos hand -- )
- hand-gadget [ screen-pos - ] keep
- mouse-enter ;
-
-: gadget-at-hand ( hand -- gadget )
- dup gadget-children [ car ] [ world get pick-up ] ?ifte ;
+ hand-gadget [ screen-pos - ] keep mouse-enter ;
: update-hand-gadget ( hand -- )
#! The hand gadget is the gadget under the hand right now.
- dup gadget-at-hand [ swap set-hand-gadget ] keep ;
+ dup world get pick-up swap set-hand-gadget ;
+
+: fire-motion ( hand -- )
+ [ motion ] swap hand-gadget handle-gesture ;
: move-hand ( x y hand -- )
dup shape-pos >r
[ move-gadget ] keep
- dup fire-leave
+ dup hand-gadget >r
dup update-hand-gadget
- [ motion ] swap handle-gesture
+ dup r> fire-leave
+ dup fire-motion
r> swap fire-enter ;
[ set-border-size ] keep [ set-border-delegate ] keep ;
: standard-border ( child delegate -- border )
- 5 <border> [ add-gadget ] keep ;
+ 5 <border> [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
: empty-border ( child -- border )
0 0 0 0 <rectangle> <gadget> standard-border ;
: 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 + ;
+ [ shape-w pick + ] keep
+ shape-h pick + ;
GENERIC: draw-shape ( obj -- )
+! Actual rectangles don't draw; use a hollow-rect, plain-rect
+! or bevel-rect instead.
M: rectangle draw-shape drop ;
TUPLE: hollow-rect delegate ;
M: bevel-rect draw-shape ( rect -- )
shape>screen >r >r rect> r> r> rect> 3 draw-bevel ;
+M: line draw-shape ( line -- )
+ >r surface get r>
+ shape>screen
+ foreground get rgb
+ lineColor ;
+
+M: ellipse draw-shape drop ;
+
+: ellipse>screen ( shape -- x y rx ry )
+ [ dup shape-x swap shape-w 2 /i + x get + ] keep
+ [ dup shape-y swap shape-h 2 /i + y get + ] keep
+ [ shape-w 2 /i ] keep
+ shape-h 2 /i ;
+
+TUPLE: hollow-ellipse delegate ;
+
+C: hollow-ellipse ( x y w h -- ellipse )
+ [ >r <ellipse> r> set-hollow-ellipse-delegate ] keep ;
+
+M: hollow-ellipse draw-shape ( ellipse -- )
+ >r surface get r> ellipse>screen foreground get rgb
+ ellipseColor ;
+
+TUPLE: plain-ellipse delegate ;
+
+C: plain-ellipse ( x y w h -- ellipse )
+ [ >r <ellipse> r> set-plain-ellipse-delegate ] keep ;
+
+M: plain-ellipse draw-shape ( ellipse -- )
+ >r surface get r> ellipse>screen background get rgb
+ filledEllipseColor ;
+
: draw-gadget ( gadget -- )
#! All drawing done inside draw-shape is done with the
#! gadget's paint. If the gadget does not have any custom
: max-width ( list -- n )
#! The width of the widest shape.
- [ shape-w ] map [ > ] top ;
+ [ [ shape-w ] map [ > ] top ] [ 0 ] ifte* ;
: max-height ( list -- n )
#! The height of the tallest shape.
- [ shape-h ] map [ > ] top ;
+ [ [ shape-h ] map [ > ] top ] [ 0 ] ifte* ;
: run-widths ( list -- w list )
#! Compute a list of running sums of widths of shapes.
M: rectangle inside? ( point rect -- ? )
over shape-x over rectangle-x-extents between? >r
swap shape-y swap rectangle-y-extents between? r> and ;
+
+! A line.
+TUPLE: line x y w h ;
+M: line shape-x line-x ;
+M: line shape-y line-y ;
+M: line shape-w line-w ;
+M: line shape-h line-h ;
+
+C: line ( x y w h -- line )
+ #! We handle negative w/h for convinience.
+ >r fix-neg >r fix-neg r> r>
+ [ set-line-h ] keep
+ [ set-line-w ] keep
+ [ set-line-y ] keep
+ [ set-line-x ] keep ;
+
+M: line move-shape ( x y line -- )
+ tuck set-line-y set-line-x ;
+
+M: line resize-shape ( w h line -- )
+ tuck set-line-h set-line-w ;
+
+M: line inside? ( point line -- ? )
+ 2drop f ;
+
+! An ellipse.
+TUPLE: ellipse x y w h ;
+M: ellipse shape-x ellipse-x ;
+M: ellipse shape-y ellipse-y ;
+M: ellipse shape-w ellipse-w ;
+M: ellipse shape-h ellipse-h ;
+
+C: ellipse ( x y w h -- line )
+ #! We handle negative w/h for convinience.
+ >r fix-neg >r fix-neg r> r>
+ [ set-ellipse-h ] keep
+ [ set-ellipse-w ] keep
+ [ set-ellipse-y ] keep
+ [ set-ellipse-x ] keep ;
+
+M: ellipse move-shape ( x y line -- )
+ tuck set-ellipse-y set-ellipse-x ;
+
+M: ellipse resize-shape ( w h line -- )
+ tuck set-ellipse-h set-ellipse-w ;
+
+M: ellipse inside? ( point line -- ? )
+ 2drop f ;
projects / factor.git / commitdiff