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

halos

cvs
Slava Pestov 2005-03-04 01:43:55 +00:00
parent 175b211160
commit c4da07c80d
22 changed files with 194 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -17,7 +17,7 @@
- console: scroll to bottom
- split preferred size and layouting
- remove shelf/pile duplication
- resizing and moving gadgets
- resizing gadgets
- faster layout
- faster repaint
- closing inspectors

59
library/tools/interpreter.factor
View File

@ -82,21 +82,11 @@ SYMBOL: meta-cf
: do-1 ( obj -- )
dup word? [ meta-word-1 ] [ push-d ] ifte ;
: (interpret) ( quot -- )
: interpret ( quot -- )
#! The quotation is called with each word as its executed.
done? [ drop ] [ [ next swap call ] keep (interpret) ] ifte ;
done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;
: interpret ( quot quot -- )
#! The first quotation is meta-interpreted, with each word
#! passed to the second quotation. Pollutes current
#! namespace.
init-interpreter swap meta-cf set (interpret) ;
: (run) ( -- )
[ do ] (interpret) ;
: run ( quot -- )
[ do ] interpret ;
: run ( -- ) [ do ] interpret ;
: set-meta-word ( word quot -- )
"meta-word" set-word-property ;
@ -117,23 +107,6 @@ SYMBOL: meta-cf
! Some useful tools
: report ( obj -- )
meta-r get vector-length " " fill write . flush ;
: (trace) ( -- )
[ dup report do ] (interpret) ;
: trace ( quot -- )
#! Trace execution of a quotation by printing each word as
#! its executed, and each literal as its pushed. Each line
#! is indented by the call stack height.
[
init-interpreter
meta-cf set
(trace)
meta-d get set-datastack
] with-scope ;
: &s
#! Print stepper data stack.
meta-d get {.} ;
@ -154,19 +127,27 @@ SYMBOL: meta-cf
#! Print stepper variable value.
meta-n get (get) ;
: not-done ( quot -- )
done? [ "Stepper is done." print drop ] [ call ] ifte ;
: stack-report ( -- )
meta-r get vector-length "=" fill write
meta-d get vector-length "-" fill write ;
: next-report ( -- obj )
next dup report meta-cf get report ;
: not-done ( quot -- )
done? [
stack-report "Stepper is done." print drop
] [
call
] ifte ;
: report ( -- )
stack-report meta-cf get . ;
: step
#! Step into current word.
[ next-report do-1 ] not-done ;
[ next do-1 report ] not-done ;
: into
#! Step into current word.
[ next-report do ] not-done ;
[ next do report ] not-done ;
: walk-banner ( -- )
"The following words control the single-stepper:" print
@ -176,9 +157,9 @@ SYMBOL: meta-cf
" ( var -- value ) inspects the stepper namestack." print
\ step prettyprint-word " -- single step over" print
\ into prettyprint-word " -- single step into" print
\ (trace) prettyprint-word " -- trace until end" print
\ (run) prettyprint-word " -- run until end" print
\ exit prettyprint-word " -- exit single-stepper" print ;
\ run prettyprint-word " -- run until end" print
\ exit prettyprint-word " -- exit single-stepper" print
report ;
: walk ( quot -- )
#! Single-step through execution of a quotation.

7
library/ui/buttons.factor
View File

@ -4,17 +4,16 @@ IN: gadgets
USING: generic kernel lists math namespaces prettyprint sdl
stdio ;
: button-down? ( n -- ? )
my-hand hand-buttons contains? ;
: button-down? ( n -- ? ) hand hand-buttons contains? ;
: mouse-over? ( gadget -- ? ) my-hand hand-gadget child? ;
: mouse-over? ( gadget -- ? ) hand hand-gadget child? ;
: button-pressed? ( button -- ? )
#! Return true if the mouse was clicked on the button, and
#! is currently over the button.
dup mouse-over? [
1 button-down? [
my-hand hand-clicked child?
hand hand-clicked child?
] [
drop f
] ifte

1
library/ui/dialogs.factor
View File

@ -20,7 +20,6 @@ TUPLE: dialog continuation delegate ;
<button> over add-gadget ;
: dialog-actions ( dialog -- )
dup moving-actions
dup [ dialog-ok ] dup set-action
[ dialog-cancel ] dup set-action ;

2
library/ui/editors.factor
View File

@ -50,7 +50,7 @@ TUPLE: editor line caret delegate ;
[ line-text get x>offset caret set ] with-editor ;
: click-editor ( editor -- )
my-hand
hand
2dup relative shape-x pick set-caret-x
request-focus ;

12
library/ui/events.factor
View File

@ -19,29 +19,29 @@ M: resize-event handle-event ( event -- )
world get relayout ;
: button-gesture ( button gesture -- [ gesture button ] )
swap unit append my-hand hand-clicked handle-gesture drop ;
swap unit append hand hand-clicked handle-gesture drop ;
M: button-down-event handle-event ( event -- )
button-event-button dup my-hand button/
button-event-button dup hand button/
[ button-down ] button-gesture ;
M: button-up-event handle-event ( event -- )
button-event-button dup my-hand button\
button-event-button dup hand button\
[ button-up ] button-gesture ;
: motion-event-pos ( event -- x y )
dup motion-event-x swap motion-event-y ;
M: motion-event handle-event ( event -- )
motion-event-pos my-hand move-hand ;
motion-event-pos hand move-hand ;
M: key-down-event handle-event ( event -- )
dup keyboard-event>binding
my-hand hand-focus handle-gesture [
hand hand-focus handle-gesture [
keyboard-event-unicode dup 0 = [
drop
] [
my-hand hand-focus user-input drop
hand hand-focus user-input drop
] ifte
] [
drop

5
library/ui/gadgets.factor
View File

@ -11,12 +11,15 @@ TUPLE: gadget
relayout? redraw?
parent children delegate ;
DEFER: default-actions
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
[ <namespace> swap set-gadget-paint ] keep
[ <namespace> swap set-gadget-gestures ] keep
[ t swap set-gadget-relayout? ] keep
[ t swap set-gadget-redraw? ] keep ;
[ t swap set-gadget-redraw? ] keep
dup default-actions ;
: <empty-gadget> ( -- gadget )
0 0 0 0 <rectangle> <gadget> ;

65
library/ui/halo.factor
View File

@ -1,20 +1,59 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: kernel math namespaces sdl ;
USING: kernel math namespaces prettyprint sdl ;
! The halo is used to move and resize gadgets.
TUPLE: halo selected delegate ;
: grab ( gadget hand -- )
[ swap screen-pos swap screen-pos - >rect ] 2keep
>r [ move-gadget ] keep r> add-gadget ;
: gadget-menu ( gadget -- assoc )
[
[[ "Inspect" [ inspect ] ]]
[[ "Unparent" [ unparent ] ]]
[[ "Move" [ hand grab ] ]]
] actionize ;
: release ( gadget world -- )
>r dup screen-pos >r dup unparent
r> >rect pick move-gadget
r> add-gadget ;
: halo-menu ( halo -- )
halo-selected gadget-menu <menu> show-menu ;
: show-halo* ( gadget -- )
#! Show the halo on a specific gadget.
halo
[ world get add-gadget ] keep
[ set-halo-selected ] keep relayout ;
: hide-halo ( -- )
halo f over set-halo-selected unparent ;
: parent-selected? ( gadget halo -- ? )
#! See if the parent of a gadget is selected with a halo.
halo-selected dup [ swap child? ] [ 2drop f ] ifte ;
: show-halo ( gadget -- )
#! If a halo is already showing on the gadget, go to the
#! parent.
halo halo-selected world get eq? [
drop hide-halo
] [
dup halo parent-selected? [
drop halo halo-selected gadget-parent
] when show-halo*
] ifte ;
: halo-actions ( gadget -- )
dup [ halo-selected hand grab ] [ button-down 1 ] set-action
dup [ halo-selected show-halo ] [ button-down 2 ] set-action
[ halo-menu ] [ button-down 3 ] set-action ;
C: halo ( -- halo )
0 0 0 0 <hollow-rect> <gadget> over set-halo-delegate
dup red foreground set-paint-property
dup halo-actions ;
M: halo layout* ( halo -- )
dup halo-selected
2dup screen-pos >rect rot move-gadget
dup shape-w swap shape-h rot resize-gadget ;
: default-actions ( gadget -- )
[ show-halo ] [ button-down 2 ] set-action ;
: moving-actions ( gadget -- )
dup
[ my-hand grab ] [ button-down 1 ] set-action
[ world get release ] [ button-up 1 ] set-action ;

41
library/ui/hand.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
USING: alien generic kernel lists math namespaces prettyprint
sdl sdl-event sdl-video stdio ;
DEFER: pick-up
@ -50,12 +50,34 @@ TUPLE: hand
click-pos clicked buttons
gadget focus delegate ;
: grab ( gadget hand -- )
#! Grab hold of a gadget; the gadget will move with the
#! hand.
2dup set-hand-clicked
[ swap screen-pos swap screen-pos - >rect ] 2keep
>r [ move-gadget ] keep r> add-gadget ;
: release* ( gadget world -- )
>r dup screen-pos >r dup unparent
r> >rect pick move-gadget
r> add-gadget ;
: release ( hand -- )
#! Release the gadget we are holding.
dup gadget-children car swap hand-world release* ;
: hand-actions ( hand -- )
#! A nice trick is that the hand is only consulted for
#! gestures when one of its children is clicked.
[ release ] [ button-up 1 ] set-action ;
C: hand ( world -- hand )
<empty-gadget>
over set-hand-delegate
[ set-hand-world ] 2keep
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
[ set-hand-gadget ] keep
[ hand-actions ] keep ;
: button/ ( n hand -- )
dup hand-gadget over set-hand-clicked
@ -71,9 +93,16 @@ C: hand ( world -- hand )
: fire-enter ( oldpos hand -- )
hand-gadget [ screen-pos - ] keep mouse-enter ;
: update-hand-gadget ( hand -- )
: find-hand-gadget ( hand -- gadget )
#! The hand gadget is the gadget under the hand right now.
dup dup hand-world pick-up swap set-hand-gadget ;
dup gadget-children [ dup hand-world pick-up ] unless ;
: update-hand-gadget ( hand -- )
dup find-hand-gadget swap set-hand-gadget ;
: motion-gesture ( hand gadget gesture -- )
#! Send a gesture like [ drag 2 ].
rot hand-buttons car unit append swap handle-gesture drop ;
: fire-motion ( hand -- )
#! Fire a motion gesture to the gadget underneath the hand,
@ -81,7 +110,7 @@ C: hand ( world -- hand )
#! gadget that was clicked.
[ motion ] over hand-gadget handle-gesture drop
dup hand-buttons [
[ drag ] swap hand-clicked handle-gesture drop
dup hand-clicked [ drag ] motion-gesture
] [
drop
] ifte ;

12
library/ui/inspector.factor
View File

@ -43,18 +43,18 @@ GENERIC: custom-sheet ( obj -- gadget )
over top-sheet over add-gadget
over slot-sheet over add-gadget
swap custom-sheet over add-gadget
line-border dup moving-actions ;
line-border ;
M: object custom-sheet drop <empty-gadget> ;
M: list custom-sheet ( list -- gadget )
[ length count ] keep zip alist>sheet "Elements:" <titled> ;
M: array custom-sheet ( array -- gadget )
[ array-capacity [ count ] keep ] keep array>list zip
alist>sheet
"Elements:" <titled> ;
[ array-capacity ] keep array>list custom-sheet ;
M: vector custom-sheet ( array -- gadget )
dup vector-length count swap vector>list zip alist>sheet
"Elements:" <titled> ;
vector>list custom-sheet ;
M: hashtable custom-sheet ( array -- gadget )
hash>alist sort-sheet alist>sheet "Entries:" <titled> ;

7
library/ui/menus.factor
View File

@ -41,3 +41,10 @@ C: menu ( assoc -- gadget )
! While a menu is open, clicking anywhere sends the click to
! the menu.
M: menu inside? ( point menu -- ? ) 2drop t ;
: actionize ( obj assoc -- assoc )
#! Prepends an object to each cdr of the assoc list. Utility
#! word for constructing menu action association lists.
[
unswons >r >r unit [ car ] cons r> append r> swons
] map-with ;

5
library/ui/presentations.factor
View File

@ -5,11 +5,6 @@ USING: kernel lists namespaces prettyprint stdio unparser ;
DEFER: inspect
: actionize ( obj assoc -- assoc )
[
unswons >r >r unit [ car ] cons r> append r> swons
] map-with ;
: object-menu ( obj -- assoc )
[
[[ "Inspect" [ inspect ] ]]

2
library/ui/root-menu.factor
View File

@ -9,7 +9,7 @@ SYMBOL: root-menu
root-menu get <menu> show-menu ;
: <console> ( -- console )
<console-pane> <scroller> line-border dup moving-actions ;
<console-pane> <scroller> line-border ;
[
[[ "Listener" [ <console> world get add-gadget ] ]]

4
library/ui/scrolling.factor
View File

@ -57,7 +57,7 @@ TUPLE: thumb offset delegate ;
: hand-y ( gadget -- y )
#! Vertical offset of hand from gadget.
my-hand swap relative shape-y ;
hand swap relative shape-y ;
: thumb-click ( thumb -- )
[ hand-y ] keep set-thumb-offset ;
@ -73,7 +73,7 @@ TUPLE: thumb offset delegate ;
: thumb-actions ( thumb -- )
dup
[ thumb-click ] [ button-down 1 ] set-action
[ thumb-motion ] [ drag ] set-action ;
[ thumb-motion ] [ drag 1 ] set-action ;
C: thumb ( -- thumb )
0 0 0 0 <plain-rect> <gadget> over set-thumb-delegate

23
library/ui/world.factor
View File

@ -2,13 +2,13 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien errors generic kernel lists math memory namespaces
sdl sdl-event sdl-video stdio strings threads ;
prettyprint sdl sdl-event sdl-video stdio strings threads ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
! world variable. The menu slot ensures that only one menu is
! open at any one time.
TUPLE: world running? hand menu delegate ;
TUPLE: world running? hand menu halo delegate ;
: <world-box> ( -- box )
0 0 0 0 <plain-rect> <gadget> ;
@ -16,11 +16,13 @@ TUPLE: world running? hand menu delegate ;
C: world ( -- world )
<world-box> over set-world-delegate
t over set-world-running?
dup <hand> over set-world-hand ;
dup <hand> over set-world-hand
dup <halo> over set-world-halo ;
M: world inside? ( point world -- ? ) 2drop t ;
: my-hand ( -- hand ) world get world-hand ;
: hand world get world-hand ;
: halo world get world-halo ;
: draw-world ( world -- )
dup gadget-redraw? [
@ -35,10 +37,21 @@ M: world inside? ( point world -- ? ) 2drop t ;
DEFER: handle-event
: layout-halo ( world -- )
world-halo dup halo-selected dup [
dup gadget-parent [
drop dup gadget-parent [ relayout ] [ drop ] ifte
] [
unparent drop
] ifte
] [
2drop
] ifte ;
: layout-world ( world -- )
dup
0 0 width get height get <rectangle> clip set-paint-property
dup layout world-hand update-hand ;
dup layout-halo dup layout world-hand update-hand ;
: world-step ( world -- ? )
dup world-running? [

47
native/arithmetic.c
View File

@ -2,13 +2,8 @@
void primitive_arithmetic_type(void)
{
CELL obj1 = dpeek();
CELL obj2 = get(ds - CELLS);
CELL type1 = TAG(obj1);
CELL type2 = TAG(obj2);
CELL type;
CELL obj1 = dpeek(), obj2 = get(ds - CELLS);
CELL type1 = TAG(obj1), type2 = TAG(obj2);
switch(type2)
{
@ -22,72 +17,64 @@ void primitive_arithmetic_type(void)
put(ds - CELLS,tag_float(to_float((obj2))));
break;
}
type = type1;
dpush(tag_fixnum(type1));
break;
case BIGNUM_TYPE:
switch(type1)
{
case FIXNUM_TYPE:
drepl(tag_bignum(to_bignum(obj1)));
type = type2;
dpush(tag_fixnum(type2));
break;
case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2))));
type = type1;
dpush(tag_fixnum(type1));
break;
default:
type = type1;
dpush(tag_fixnum(type1));
break;
}
break;
case RATIO_TYPE:
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
type = type2;
case FIXNUM_TYPE: case BIGNUM_TYPE:
dpush(tag_fixnum(type2));
break;
case FLOAT_TYPE:
put(ds - CELLS,tag_float(to_float((obj2))));
type = type1;
dpush(tag_fixnum(type1));
break;
default:
type = type1;
dpush(tag_fixnum(type1));
break;
}
break;
case FLOAT_TYPE:
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case RATIO_TYPE:
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE:
drepl(tag_float(to_float(obj1)));
type = type2;
dpush(tag_fixnum(type2));
break;
default:
type = type1;
dpush(tag_fixnum(type1));
break;
}
break;
case COMPLEX_TYPE:
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case RATIO_TYPE:
case FLOAT_TYPE:
type = type2;
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE:
dpush(tag_fixnum(type2));
break;
default:
type = type1;
dpush(tag_fixnum(type1));
break;
}
break;
default:
type = type2;
dpush(tag_fixnum(type2));
break;
}
dpush(tag_fixnum(type));
}

28
native/array.c
View File

@ -1,24 +1,17 @@
#include "factor.h"
/* untagged */
F_ARRAY* allot_array(CELL type, CELL capacity)
{
F_ARRAY* array;
array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
F_ARRAY* array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
array->capacity = tag_fixnum(capacity);
return array;
}
/* untagged */
F_ARRAY* array(CELL type, CELL capacity, CELL fill)
{
int i;
F_ARRAY* array = allot_array(type, capacity);
int i; F_ARRAY* array = allot_array(type, capacity);
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
return array;
}
@ -43,27 +36,20 @@ void primitive_tuple(void)
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
int i;
F_ARRAY* new_array;
int i; F_ARRAY* new_array;
CELL curr_cap = array_capacity(array);
if(curr_cap >= capacity)
return array;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,curr_cap * CELLS);
for(i = curr_cap; i < capacity; i++)
put(AREF(new_array,i),fill);
return new_array;
}
void primitive_grow_array(void)
{
F_ARRAY* array;
CELL capacity;
F_ARRAY* array; CELL capacity;
maybe_garbage_collection();
array = untag_array(dpop());
capacity = to_fixnum(dpop());
@ -79,16 +65,14 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
void fixup_array(F_ARRAY* array)
{
int i = 0;
CELL capacity = array_capacity(array);
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
data_fixup((void*)AREF(array,i));
}
void collect_array(F_ARRAY* array)
{
int i = 0;
CELL capacity = array_capacity(array);
int i = 0; CELL capacity = array_capacity(array);
for(i = 0; i < capacity; i++)
copy_handle((void*)AREF(array,i));
}

14
native/string.c
View File

@ -80,19 +80,19 @@ void primitive_memory_to_string(void)
}
/* untagged */
F_STRING* from_c_string(const BYTE* c_string)
F_STRING* from_c_string(const char* c_string)
{
return memory_to_string(c_string,strlen(c_string));
return memory_to_string((BYTE*)c_string,strlen(c_string));
}
/* FFI calls this */
void box_c_string(const BYTE* c_string)
void box_c_string(const char* c_string)
{
dpush(tag_object(from_c_string(c_string)));
}
/* untagged */
BYTE* to_c_string(F_STRING* s)
char* to_c_string(F_STRING* s)
{
CELL i;
CELL capacity = string_capacity(s);
@ -122,18 +122,18 @@ void primitive_string_to_memory(void)
}
/* untagged */
BYTE* to_c_string_unchecked(F_STRING* s)
char* to_c_string_unchecked(F_STRING* s)
{
CELL capacity = string_capacity(s);
F_STRING* _c_str = allot_string(capacity / CHARS + 1);
BYTE* c_str = (BYTE*)(_c_str + 1);
string_to_memory(s,c_str);
c_str[capacity] = '\0';
return c_str;
return (char*)c_str;
}
/* FFI calls this */
BYTE* unbox_c_string(void)
char* unbox_c_string(void)
{
return to_c_string(untag_string(dpop()));
}

10
native/string.h
View File

@ -26,13 +26,13 @@ F_STRING* allot_string(CELL capacity);
F_STRING* string(CELL capacity, CELL fill);
void rehash_string(F_STRING* str);
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, uint16_t fill);
BYTE* to_c_string(F_STRING* s);
BYTE* to_c_string_unchecked(F_STRING* s);
char* to_c_string(F_STRING* s);
char* to_c_string_unchecked(F_STRING* s);
void primitive_string_to_memory(void);
DLLEXPORT void box_c_string(const BYTE* c_string);
F_STRING* from_c_string(const BYTE* c_string);
DLLEXPORT void box_c_string(const char* c_string);
F_STRING* from_c_string(const char* c_string);
void primitive_memory_to_string(void);
DLLEXPORT BYTE* unbox_c_string(void);
DLLEXPORT char* unbox_c_string(void);
DLLEXPORT uint16_t* unbox_utf16_string(void);
/* untagged & unchecked */

2
native/unix/io.c
View File

@ -83,7 +83,7 @@ bool perform_copy_from_io_task(F_PORT* port, F_PORT* other_port)
if(can_write(other_port,port->buf_fill))
{
write_string_raw(other_port,
(BYTE*)(untag_string(port->buffer) + 1),
(char*)(untag_string(port->buffer) + 1),
port->buf_fill);
port->buf_pos = port->buf_fill = 0;
}

2
native/unix/write.c
View File

@ -91,7 +91,7 @@ void write_char_8(F_PORT* port, F_FIXNUM ch)
}
/* Caller must ensure buffer is of the right size. */
void write_string_raw(F_PORT* port, BYTE* str, CELL len)
void write_string_raw(F_PORT* port, char* str, CELL len)
{
/* Append string to buffer */
memcpy((void*)((CELL)untag_string(port->buffer) + sizeof(F_STRING)

2
native/write.h
View File

@ -4,6 +4,6 @@ void primitive_can_write(void);
void primitive_add_write_io_task(void);
bool perform_write_io_task(F_PORT* port);
void write_char_8(F_PORT* port, F_FIXNUM ch);
void write_string_raw(F_PORT* port, BYTE* str, CELL len);
void write_string_raw(F_PORT* port, char* str, CELL len);
void write_string_8(F_PORT* port, F_STRING* str);
void primitive_write_8(void);