string-compare ==> lexi, string> ==> lexi>

CHANGES.txt

@@ -27,7 +27,11 @@ Factor 0.76:
   [ "Hello" % " world" % ] make-string
   
   Now, the former raises a type error.
-  
+
+- The string-compare primitive has been replaced with the lexi word
+  which now operates on any pair of sequences of numbers. The
+  string> word has been replaced with lexi>.
+
 - The stream-write, stream-write-attr, write and write-attr generic   
   words no longer accept a character as an argument. Use the new
   stream-write1 and write1 generic words to write single characters.

TODO.FACTOR.txt

@@ -7,12 +7,11 @@
 - rollovers broken with menus
 - menu dragging
 - fix up the min thumb size hack
-- bevel borders
 - nicer scrollbars with up/down buttons
 - gaps in pack layout
 - fix listener prompt display after presentation commands invoked
 - stack display bugs
-- simple tutorial
+- tutorial: clickable code snippets
 - parser::skip clean up
 
 + misc

library/bootstrap/primitives.factor

@@ -44,7 +44,6 @@ vocabularies get [
     [ "dispatch" "kernel-internals"           [ [ fixnum vector ] [ ] ] ]
     [ "cons" "lists"                          [ [ object object ] [ cons ] ] ]
     [ "<vector>" "vectors"                    [ [ integer ] [ vector ] ] ]
-    [ "string-compare" "strings"              [ [ string string ] [ integer ] ] ]
     [ "rehash-string" "strings"               [ [ string ] [ ] ] ]
     [ "<sbuf>" "strings"                      [ [ integer ] [ sbuf ] ] ]
     [ "sbuf>string" "strings"                 [ [ sbuf ] [ string ] ] ]

library/collections/sequence-eq.factor

@@ -31,3 +31,11 @@ M: sequence = ( obj seq -- ? )
     ] [
         over type over type eq? [ sequence= ] [ 2drop f ] ifte
     ] ifte ;
+
+M: string = ( obj str -- ? )
+    over string? [
+        over hashcode over hashcode number=
+        [ sequence= ] [ 2drop f ] ifte
+    ] [
+        2drop f
+    ] ifte ;

library/collections/sequences-epilogue.factor

@@ -211,6 +211,29 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
     #! Is every element of seq1 in seq2
     swap [ swap member? ] all-with? ;
 
+! Lexicographic comparison
+: (lexi) ( seq seq i limit -- n )
+    2dup >= [
+        2drop swap length swap length -
+    ] [
+        >r 3dup 2nth 2dup = [
+            2drop 1 + r> (lexi)
+        ] [
+            r> drop - >r 3drop r>
+        ] ifte
+    ] ifte ;
+
+: lexi ( s1 s2 -- n )
+    #! Lexicographically compare two sequences of numbers
+    #! (usually strings). Negative if s1<s2, zero if s1=s2,
+    #! positive if s1>s2.
+    0 pick length pick length min (lexi) ;
+
+: lexi> ( seq seq -- ? )
+    #! Test if the first sequence follows the second
+    #! lexicographically.
+    lexi 0 > ;
+
 IN: kernel
 
 : depth ( -- n )

library/collections/strings-epilogue.factor

@@ -4,8 +4,7 @@ IN: strings
 USING: generic kernel kernel-internals lists math namespaces
 sequences strings ;
 
-: empty-sbuf ( len -- sbuf )
+: empty-sbuf ( len -- sbuf ) dup <sbuf> [ set-length ] keep ;
-    dup <sbuf> [ set-length ] keep ;
 
 : fill ( count char -- string ) <repeated> >string ;
 
@@ -28,7 +27,6 @@ M: string thaw >sbuf ;
 
 M: string like ( seq sbuf -- string ) drop >string ;
 
-M: sbuf clone ( sbuf -- sbuf )
+M: sbuf clone ( sbuf -- sbuf ) >sbuf ;
-    [ length <sbuf> dup ] keep nappend ;
 
 M: sbuf like ( seq sbuf -- sbuf ) drop >sbuf ;

library/collections/strings.factor

@@ -7,28 +7,12 @@ USING: generic kernel kernel-internals lists math sequences ;
 DEFER: string?
 BUILTIN: string 12 string? [ 1 length f ] [ 2 hashcode f ] ;
 
-M: string =
+M: string nth ( n str -- ch ) bounds-check char-slot ;
-    over string? [
-        over hashcode over hashcode number= [
-            string-compare 0 eq?
-        ] [
-            2drop f
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-M: string nth ( n str -- ch )
-    bounds-check char-slot ;
 
 GENERIC: >string ( seq -- string )
 
 M: string >string ;
 
-: string> ( str1 str2 -- ? )
-    ! Returns if the first string lexicographically follows str2
-    string-compare 0 > ;
-
 ! Characters
 PREDICATE: integer blank     " \t\n\r" member? ;
 PREDICATE: integer letter    CHAR: a CHAR: z between? ;

library/collections/vectors-epilogue.factor

@@ -5,22 +5,16 @@ math-internals sequences ;
 
 IN: vectors
 
-: empty-vector ( len -- vec )
+: empty-vector ( len -- vec ) dup <vector> [ set-length ] keep ;
-    #! Creates a vector with 'len' elements set to f. Unlike
-    #! <vector>, which gives an empty vector with a certain
-    #! capacity.
-    dup <vector> [ set-length ] keep ;
 
 : >vector ( list -- vector )
     dup length <vector> [ swap nappend ] keep ;
 
 M: repeated thaw >vector ;
 
-M: vector clone ( vector -- vector )
+M: vector clone ( vector -- vector ) >vector ;
-    >vector ;
 
-: zero-vector ( n -- vector )
+: zero-vector ( n -- vector ) 0 <repeated> >vector ;
-    0 <repeated> >vector ;
 
 M: general-list thaw >vector ;
 

library/httpd/browser-responder.factor

@@ -57,7 +57,7 @@ sequences ;
   #! Write out the HTML for the list of words in a vocabulary.
   <select name= "words" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select> 
     words [ 
-      word-name dup "current-word" get [ "" ] unless* string-compare 0 = [
+      word-name dup "current-word" get [ "" ] unless* = [
       "<option selected>" write
      ] [
         "<option>" write

library/io/files.factor

@@ -8,7 +8,7 @@ USING: kernel lists namespaces sequences strings ;
 : path+ ( path path -- path ) "/" swap append3 ;
 : exists? ( file -- ? ) stat >boolean ;
 : directory? ( file -- ? ) stat car ;
-: directory ( dir -- list ) (directory) [ string> ] sort ;
+: directory ( dir -- list ) (directory) [ lexi> ] sort ;
 : file-length ( file -- length ) stat third ;
 : file-extension ( filename -- extension )
     "." split cdr dup [ peek ] when ;

library/test/lists/combinators.factor

@@ -14,7 +14,7 @@ USE: sequences
 
 [ "fdsfs" [ > ] sort ] unit-test-fails
 [ [ ] ] [ [ ] [ > ] sort ] unit-test
-[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ string> ] sort ] unit-test
+[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ lexi> ] sort ] unit-test
 [ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ > ] sort ] unit-test
 
 [ f ] [ [ { } { } "Hello" ] [ = ] fiber? ] unit-test

library/test/strings.factor

@@ -71,8 +71,8 @@ unit-test
 [ t ] [ CHAR: 0 digit? ] unit-test
 [ f ] [ CHAR: x digit? ] unit-test
 
-[ t ] [ "abc" "abd" string-compare 0 < ] unit-test
+[ t ] [ "abc" "abd" lexi 0 < ] unit-test
-[ t ] [ "z" "abd" string-compare 0 > ] unit-test
+[ t ] [ "z" "abd" lexi 0 > ] unit-test
 
 [ f ] [ [ 0 10 "hello" subseq ] [ not ] catch ] unit-test
 

library/test/words.factor

@@ -58,6 +58,22 @@ GENERIC: testing
 
 [ f ] [ \ testing generic? ] unit-test
 
+[ f ] [ gensym interned? ] unit-test
+
+: forgotten ;
+: another-forgotten ;
+
+[ f ] [ \ forgotten interned? ] unit-test
+
+FORGET: forgotten
+
+[ f ] [ \ another-forgotten interned? ] unit-test
+
+FORGET: another-forgotten
+: another-forgotten ;
+
+[ t ] [ \ car interned? ] unit-test
+
 ! This has to be the last test in the file.
 : test-last ( -- ) ;
 word word-name "last-word-test" set

library/tools/inspector.factor

@@ -48,9 +48,6 @@ M: hashtable sheet hash>alist unzip 2list ;
     seq-transpose
     [ " | " join ] map ;
 
-: interned? ( word -- ? )
-    dup word-name swap word-vocabulary vocab hash ;
-
 : class-banner ( word -- )
     dup metaclass dup [
         "This is a class whose behavior is specifed by the " write

library/tools/memory.factor

@@ -106,14 +106,6 @@ M: object (each-slot) ( quot obj -- )
     #! Print heap allocation breakdown.
     0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;
 
-: orphan? ( word -- ? )
-    #! Test if the word is not a member of its vocabulary.
-    dup dup word-name swap word-vocabulary dup [
-        vocab dup [ hash eq? not ] [ 3drop t ] ifte
-    ] [
-        3drop t
-    ] ifte ;
-
 : orphans ( word -- list )
     #! Orphans are forgotten but still referenced.
-    [ word? ] instances [ orphan? ] subset ;
+    [ word? ] instances [ interned? not ] subset ;

library/ui/books.factor

@@ -14,9 +14,9 @@ M: book pref-dim ( book -- dim )
     gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ;
 
 M: book layout* ( book -- )
-    dup shape-dim over gadget-children [
+    dup rectangle-dim over gadget-children [
         f over set-gadget-visible?
-        { 0 0 0 } over set-shape-loc
+        { 0 0 0 } over set-rectangle-loc
         set-gadget-dim
     ] each-with
     dup book-page swap gadget-children nth

library/ui/borders.factor

@@ -21,10 +21,10 @@ C: border ( child delegate size -- border )
     <bevel-gadget> { 5 5 0 } <border> ;
 
 : layout-border-loc ( border -- )
-    dup border-size swap gadget-child set-shape-loc ;
+    dup border-size swap gadget-child set-rectangle-loc ;
 
 : layout-border-dim ( border -- )
-    dup shape-dim over border-size 2 v*n v-
+    dup rectangle-dim over border-size 2 v*n v-
     swap gadget-child set-gadget-dim ;
 
 M: border pref-dim ( border -- dim )

library/ui/editors.factor

@@ -50,7 +50,7 @@ TUPLE: editor line caret ;
     ] with-editor ;
 
 : click-editor ( editor -- )
-    dup hand relative shape-x over set-caret-x request-focus ;
+    dup hand relative first over set-caret-x request-focus ;
 
 : editor-actions ( editor -- )
     [
@@ -81,7 +81,7 @@ C: editor ( text -- )
     0 0 3vector ;
 
 : caret-dim ( editor -- w h )
-    shape-dim { 0 1 1 } v* { 1 0 0 } v+ ;
+    rectangle-dim { 0 1 1 } v* { 1 0 0 } v+ ;
 
 M: editor user-input* ( ch editor -- ? )
     [ insert-char ] with-editor  t ;
@@ -91,7 +91,7 @@ M: editor pref-dim ( editor -- dim )
 
 M: editor layout* ( editor -- )
     dup editor-caret over caret-dim swap set-gadget-dim
-    dup editor-caret swap caret-loc swap set-shape-loc ;
+    dup editor-caret swap caret-loc swap set-rectangle-loc ;
 
 M: editor draw-gadget* ( editor -- )
     dup delegate draw-gadget*

library/ui/frames.factor

@@ -83,7 +83,7 @@ SYMBOL: frame-bottom-run
     var-frame-bottom ;
 
 : move-gadget ( x y gadget -- )
-    >r 0 3vector r> set-shape-loc ;
+    >r 0 3vector r> set-rectangle-loc ;
 
 : reshape-gadget ( x y w h gadget -- )
     [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;

library/ui/gadgets.factor

@@ -42,12 +42,12 @@ DEFER: add-invalid
     dup add-invalid (relayout-down) ;
 
 : set-gadget-dim ( dim gadget -- )
-    2dup shape-dim =
+    2dup rectangle-dim =
-    [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
+    [ 2drop ] [ [ set-rectangle-dim ] keep relayout-down ] ifte ;
 
 GENERIC: pref-dim ( gadget -- dim )
 
-M: gadget pref-dim shape-dim ;
+M: gadget pref-dim rectangle-dim ;
 
 GENERIC: layout* ( gadget -- )
 

library/ui/gestures.factor

@@ -44,7 +44,7 @@ SYMBOL: button-down
     #! enter gesture, since the mouse did not enter. Otherwise,
     #! fire an enter gesture and go on to the parent.
     [
-        [ shape-loc v+ ] keep
+        [ rectangle-loc v+ ] keep
         2dup inside? [ mouse-enter ] hierarchy-gesture
     ] each-parent 2drop ;
 
@@ -53,7 +53,7 @@ SYMBOL: button-down
     #! leave gesture, since the mouse did not leave. Otherwise,
     #! fire a leave gesture and go on to the parent.
     [
-        [ shape-loc v+ ] keep
+        [ rectangle-loc v+ ] keep
         2dup inside? [ mouse-leave ] hierarchy-gesture
     ] each-parent 2drop ;
 

library/ui/hand.factor

@@ -13,7 +13,7 @@ prettyprint sdl sequences vectors ;
     #! in any subgadget. If not, see if it is contained in the
     #! box delegate.
     dup gadget-visible? >r 2dup inside? r> drop [
-        [ translate ] keep 2dup
+        [ rectangle-loc v- ] keep 2dup
         (pick-up) [ pick-up ] [ nip ] ?ifte
     ] [
         2drop f
@@ -45,13 +45,13 @@ C: hand ( world -- hand )
     [ hand-buttons remove ] keep set-hand-buttons ;
 
 : fire-leave ( hand gadget -- )
-    [ swap shape-loc swap screen-loc v- ] keep mouse-leave ;
+    [ swap rectangle-loc swap screen-loc v- ] keep mouse-leave ;
 
 : fire-enter ( oldpos hand -- )
     hand-gadget [ screen-loc v- ] keep mouse-enter ;
 
 : update-hand-gadget ( hand -- )
-    [ world get pick-up ] keep set-hand-gadget ;
+    [ rectangle-loc world get pick-up ] keep set-hand-gadget ;
 
 : motion-gesture ( hand gadget gesture -- )
     #! Send a gesture like [ drag 2 ].
@@ -66,8 +66,8 @@ C: hand ( world -- hand )
     [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ;
 
 : move-hand ( loc hand -- )
-    dup shape-loc >r
+    dup rectangle-loc >r
-    [ set-shape-loc ] keep
+    [ set-rectangle-loc ] keep
     dup hand-gadget >r
     dup update-hand-gadget
     dup r> fire-leave
@@ -76,7 +76,7 @@ C: hand ( world -- hand )
 
 : update-hand ( hand -- )
     #! Called when a gadget is removed or added.
-    dup shape-loc swap move-hand ;
+    dup rectangle-loc swap move-hand ;
 
 : request-focus ( gadget -- )
     focusable-child

library/ui/hierarchy.factor

@@ -40,6 +40,9 @@ sequences vectors ;
     #! is the gadget itself.
     dup [ dup gadget-parent parents cons ] when ;
 
+: find-parent ( gadget quot -- ? )
+    >r parents r> find nip ;
+
 : each-parent ( gadget quot -- ? )
     #! Keep executing the quotation on higher and higher
     #! parents until it returns f.
@@ -47,7 +50,7 @@ sequences vectors ;
 
 : screen-loc ( gadget -- point )
     #! The position of the gadget on the screen.
-    parents { 0 0 0 } [ shape-loc v+ ] reduce ;
+    parents { 0 0 0 } [ rectangle-loc v+ ] reduce ;
 
 : relative ( g1 g2 -- g2-g1 )
     screen-loc swap screen-loc v- ;

library/ui/incremental.factor

@@ -24,7 +24,7 @@ M: incremental layout* drop ;
 
 : next-cursor ( gadget incremental -- cursor )
     [
-        swap shape-dim swap incremental-cursor
+        swap rectangle-dim swap incremental-cursor
         2dup v+ >r vmax r>
     ] keep  pack-vector set-axis ;
 
@@ -33,10 +33,10 @@ M: incremental layout* drop ;
 
 : incremental-loc ( gadget incremental -- )
     dup incremental-cursor swap pack-vector v*
-    swap set-shape-loc ;
+    swap set-rectangle-loc ;
 
 : prefer-incremental ( gadget -- )
-    dup pref-dim swap set-shape-dim ;
+    dup pref-dim swap set-rectangle-dim ;
 
 : add-incremental ( gadget incremental -- )
     2dup (add-gadget)
@@ -46,4 +46,6 @@ M: incremental layout* drop ;
     prefer-incremental ;
 
 : clear-incremental ( incremental -- )
-    dup (clear-gadget) { 0 0 0 } swap set-incremental-cursor ;
+    dup (clear-gadget)
+    { 0 0 0 } over set-incremental-cursor
+    gadget-parent [ relayout ] when* ;

library/ui/init-world.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic io kernel listener math namespaces prettyprint
-sequences styles threads ;
+sequences styles threads words ;
 
 SYMBOL: stack-display
 
@@ -38,7 +38,9 @@ SYMBOL: stack-display
         [
             pane get [
                 [ ui.s ] listener-hook set
-                clear print-banner listener
+                clear print-banner
+                "Tutorial" [ [ tutorial ] pane get pane-call ] <button> gadget.
+                listener
             ] with-stream
         ] in-thread
         

library/ui/layouts.factor

@@ -27,7 +27,7 @@ TUPLE: pack align fill vector ;
 
 : packed-dim-2 ( gadget sizes -- list )
     [
-        over shape-dim { 1 1 1 } vmax over v-
+        over rectangle-dim { 1 1 1 } vmax over v-
         rot pack-fill v*n v+
     ] map-with ;
 
@@ -42,9 +42,9 @@ TUPLE: pack align fill vector ;
     { 0 0 0 } [ v+ ] accumulate ;
 
 : packed-loc-2 ( gadget sizes -- list )
-    >r dup shape-dim { 1 1 1 } vmax over r>
+    >r dup rectangle-dim { 1 1 1 } vmax over r>
     packed-dim-2 [ v- ] map-with
-    >r dup pack-align swap shape-dim { 1 1 1 } vmax r>
+    >r dup pack-align swap rectangle-dim { 1 1 1 } vmax r>
     [ >r 2dup r> v- n*v ] map 2nip ;
 
 : (packed-locs) ( gadget sizes -- list )
@@ -52,7 +52,7 @@ TUPLE: pack align fill vector ;
 
 : packed-locs ( gadget sizes -- )
     over gadget-children >list >r (packed-locs) r>
-    zip [ uncons set-shape-loc ] each ;
+    zip [ uncons set-rectangle-loc ] each ;
 
 : packed-layout ( gadget sizes -- )
     2dup packed-locs packed-dims ;

library/ui/menus.factor

@@ -4,7 +4,7 @@ IN: gadgets
 USING: generic kernel lists math namespaces sequences ;
 
 : show-menu ( menu -- )
-    hand screen-loc over set-shape-loc show-glass ;
+    hand screen-loc over set-rectangle-loc show-glass ;
 
 : menu-item-border ( child -- border )
     <plain-gadget> { 1 1 0 } <border> ;

library/ui/paint.factor

@@ -114,7 +114,7 @@ TUPLE: gradient vector from to ;
     dup first [ 3dup gradient-y ] repeat 2drop ;
 
 M: gradient draw-interior ( gadget gradient -- )
-    swap shape-dim { 1 1 1 } vmax
+    swap rectangle-dim { 1 1 1 } vmax
     over gradient-vector { 1 0 0 } =
     [ horiz-gradient ] [ vert-gradient ] ifte ;
 
@@ -146,7 +146,7 @@ M: bevel draw-boundary ( gadget boundary -- )
     #! Ugly code.
     bevel-width [
         [
-            >r x get y get 0 3vector over shape-dim over v+ r>
+            >r origin over rectangle-dim over v+ r>
             { 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
             rot draw-bevel
         ] 2keep

library/ui/scrolling.factor

@@ -11,7 +11,7 @@ TUPLE: viewport origin bottom? ;
 : viewport-dim gadget-child pref-dim ;
 
 : fix-scroll ( origin viewport -- origin )
-    dup shape-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
+    dup rectangle-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
 
 : scroll ( origin viewport -- )
     [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
@@ -35,13 +35,13 @@ M: viewport pref-dim gadget-child pref-dim ;
 
 M: viewport layout* ( viewport -- )
     dup gadget-child dup prefer
-    >r viewport-origin* r> set-shape-loc ;
+    >r viewport-origin* r> set-rectangle-loc ;
 
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
 
 : visible-portion ( viewport -- vector )
-    dup shape-dim { 1 1 1 } vmax
+    dup rectangle-dim { 1 1 1 } vmax
     swap viewport-dim { 1 1 1 } vmax
     v/ { 1 1 1 } vmin ;
 
@@ -106,13 +106,13 @@ C: slider ( viewport vector -- slider )
 : slider-dim { 16 16 16 } ;
 
 : thumb-dim ( slider -- h )
-    [ shape-dim dup ] keep >thumb slider-dim vmax vmin ;
+    [ rectangle-dim dup ] keep >thumb slider-dim vmax vmin ;
 
 M: slider pref-dim drop slider-dim ;
 
 M: slider layout* ( slider -- )
     dup thumb-loc over slider-vector v*
-    over slider-thumb set-shape-loc
+    over slider-thumb set-rectangle-loc
     dup thumb-dim over slider-vector v* slider-dim vmax
     swap slider-thumb set-gadget-dim ;
 

library/ui/shapes.factor

@@ -9,16 +9,14 @@ SYMBOL: y
 
 : origin ( -- loc ) x get y get 0 3vector ;
 
-GENERIC: inside? ( loc shape -- ? )
+TUPLE: rectangle loc dim ;
-GENERIC: shape-loc ( shape -- loc )
-GENERIC: set-shape-loc ( loc shape -- )
-GENERIC: shape-dim ( shape -- dim )
-GENERIC: set-shape-dim ( dim shape -- )
 
-: shape-x shape-loc first ;
+GENERIC: inside? ( loc shape -- ? )
-: shape-y shape-loc second ;
+
-: shape-w shape-dim first ;
+: shape-x rectangle-loc first ;
-: shape-h shape-dim second ;
+: shape-y rectangle-loc second ;
+: shape-w rectangle-dim first ;
+: shape-h rectangle-dim second ;
 
 : with-trans ( shape quot -- )
     #! All drawing done inside the quotation is translated
@@ -30,29 +28,11 @@ GENERIC: set-shape-dim ( dim shape -- )
         r> call
     ] with-scope ; inline
 
-: shape-pos ( shape -- pos )
-    dup shape-x swap shape-y rect> ;
-
 : shape-bounds ( shape -- loc dim )
-    dup shape-loc swap shape-dim ;
+    dup rectangle-loc swap rectangle-dim ;
 
 : shape-extent ( shape -- loc dim )
-    dup shape-loc dup rot shape-dim v+ ;
+    dup rectangle-loc dup rot rectangle-dim v+ ;
-
-: translate ( shape shape -- point )
-    #! Translate a point relative to the shape.
-    swap shape-loc swap shape-loc v- ;
-
-M: vector shape-loc ;
-M: vector shape-dim drop { 0 0 0 } ;
-
-TUPLE: rectangle loc dim ;
-
-M: rectangle shape-loc rectangle-loc ;
-M: rectangle set-shape-loc set-rectangle-loc ;
-
-M: rectangle shape-dim rectangle-dim ;
-M: rectangle set-shape-dim set-rectangle-dim ;
 
 : screen-bounds ( shape -- rect )
     shape-bounds >r origin v+ r> <rectangle> ;

library/ui/splitters.factor

@@ -17,7 +17,7 @@ TUPLE: splitter split ;
 
 : divider-motion ( splitter -- )
     dup hand>split
-    over shape-dim { 1 1 1 } vmax v/ over pack-vector v.
+    over rectangle-dim { 1 1 1 } vmax v/ over pack-vector v.
     0 max 1 min over set-splitter-split relayout ;
 
 : divider-actions ( thumb -- )
@@ -45,14 +45,14 @@ C: splitter ( first second split vector -- splitter )
     { 1 0 0 } <splitter> ;
 
 : splitter-part ( splitter -- vec )
-    dup splitter-split swap shape-dim
+    dup splitter-split swap rectangle-dim
     n*v divider-size 1/2 v*n v- ;
 
 : splitter-layout ( splitter -- [ a b c ] )
     [
         dup splitter-part ,
         divider-size ,
-        dup shape-dim divider-size v- swap splitter-part v- ,
+        dup rectangle-dim divider-size v- swap splitter-part v- ,
     ] make-list ;
 
 M: splitter layout* ( splitter -- )

library/ui/tutorial.factor

@@ -320,4 +320,5 @@ sequences styles ;
     dup 18 font-size set-paint-prop
     <book-browser> ;
 
-: tutorial <tutorial> gadget. ;
+: tutorial ( -- )
+    ensure-ui <tutorial> gadget. ;

library/ui/ui.factor

@@ -10,7 +10,7 @@ IN: shells
     #! dimensions.
     ttf-init
     ?init-world
-    world get shape-dim 2unseq 0 SDL_RESIZABLE [
+    world get rectangle-dim 2unseq 0 SDL_RESIZABLE [
         0 x set 0 y set [
             "Factor " version append dup SDL_WM_SetCaption
             start-world

library/vocabularies.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: words USING: hashtables kernel lists namespaces strings
+IN: words
-sequences ;
+USING: hashtables kernel lists namespaces strings sequences ;
 
 SYMBOL: vocabularies
 
@@ -10,7 +10,7 @@ SYMBOL: vocabularies
 
 : vocabs ( -- list )
     #! Push a list of vocabularies.
-    vocabularies get hash-keys [ string> ] sort ;
+    vocabularies get hash-keys [ lexi> ] sort ;
 
 : vocab ( name -- vocab )
     #! Get a vocabulary.
@@ -86,6 +86,14 @@ SYMBOL: vocabularies
     dup uncrossref
     dup word-vocabulary vocab [ word-name off ] bind ;
 
+: interned? ( word -- ? )
+    #! Test if the word is a member of its vocabulary.
+    dup dup word-name swap word-vocabulary dup [
+        vocab dup [ hash eq? ] [ 3drop f ] ifte
+    ] [
+        3drop f
+    ] ifte ;
+
 : init-search-path ( -- )
     ! For files
     "scratchpad" "file-in" set

library/words.factor

@@ -33,7 +33,7 @@ M: word set-word-primitive ( n w -- )
 
 : word-sort ( list -- list )
     #! Sort a list of words by name.
-    [ swap word-name swap word-name string> ] sort ;
+    [ swap word-name swap word-name lexi> ] sort ;
 
 ! The cross-referencer keeps track of word dependencies, so that
 ! words can be recompiled when redefined.

native/debug.c

@@ -1,5 +1,25 @@
 #include "factor.h"
 
+F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2)
+{
+	CELL len1 = string_capacity(s1);
+	CELL len2 = string_capacity(s2);
+
+	CELL limit = (len1 < len2 ? len1 : len2);
+
+	CELL i = 0;
+	while(i < limit)
+	{
+		u16 c1 = string_nth(s1,i);
+		u16 c2 = string_nth(s2,i);
+		if(c1 != c2)
+			return c1 - c2;
+		i++;
+	}
+
+	return len1 - len2;
+}
+
 /* Implements some Factor library words in C, to dump a stack in a semi-human-readable
 form without any Factor code executing.. This is not used during normal execution, only
 when the runtime dies. */

native/primitives.c

@@ -10,7 +10,6 @@ void* primitives[] = {
 	primitive_dispatch,
 	primitive_cons,
 	primitive_vector,
-	primitive_string_compare,
 	primitive_rehash_string,
 	primitive_sbuf,
 	primitive_sbuf_to_string,

native/string.c

@@ -177,31 +177,3 @@ void primitive_set_char_slot(void)
 	CELL value = untag_fixnum_fast(dpop());
 	set_string_nth(string,index,value);
 }
-
-F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2)
-{
-	CELL len1 = string_capacity(s1);
-	CELL len2 = string_capacity(s2);
-
-	CELL limit = (len1 < len2 ? len1 : len2);
-
-	CELL i = 0;
-	while(i < limit)
-	{
-		u16 c1 = string_nth(s1,i);
-		u16 c2 = string_nth(s2,i);
-		if(c1 != c2)
-			return c1 - c2;
-		i++;
-	}
-
-	return len1 - len2;
-}
-
-void primitive_string_compare(void)
-{
-	F_STRING* s2 = untag_string(dpop());
-	F_STRING* s1 = untag_string(dpop());
-
-	dpush(tag_fixnum(string_compare(s1,s2)));
-}

native/string.h

@@ -60,5 +60,3 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
 
 void primitive_char_slot(void);
 void primitive_set_char_slot(void);
-F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
-void primitive_string_compare(void);