! The player's ship
-! Flags that can be set to move the ship
-SYMBOL: left
-SYMBOL: right
-
TRAITS: ship
M: ship draw ( actor -- )
[
: infix ( list -- quot )
#! Convert an infix expression (passed in as a list) to
#! postfix.
- [, 10 <vector> exprs set (infix) end ,] ;
+ [ 10 <vector> exprs set (infix) end ] make-list ;
[ [ ] ] [ [ ] infix ] unit-test
[ [ 1 ] ] [ [ 1 ] infix ] unit-test
: val 0.85 ;
: <color-map> ( nb-cols -- map )
- [,
+ [
dup [
360 * over succ / 360 / sat val
hsv>rgb 1.0 scale-rgba ,
] times*
- ,] list>vector nip ;
+ ] make-list list>vector nip ;
: absq >rect swap sq swap sq + ;
: hh ( duration -- str ) 60 /i ;
: mm ( duration -- str ) 60 mod unparse 2 digits ;
-: hh:mm ( millis -- str ) <% dup hh % ":" % mm % %> ;
+: hh:mm ( millis -- str ) [ dup hh , ":" , mm , ] make-list ;
: print-entry ( duration description -- )
dup write
"\e[4" swap "m" cat3 ; inline
: ansi-attrs ( style -- )
- "bold" over assoc [ bold % ] when
- "ansi-fg" over assoc [ fg % ] when*
- "ansi-bg" over assoc [ bg % ] when*
+ "bold" over assoc [ bold , ] when
+ "ansi-fg" over assoc [ fg , ] when*
+ "ansi-bg" over assoc [ bg , ] when*
drop ;
: ansi-attr-string ( string style -- string )
- <% ansi-attrs % reset % %> ;
+ [ ansi-attrs , reset , ] make-string ;
: <ansi-stream> ( stream -- stream )
#! Wraps the given stream in an ANSI stream. ANSI streams
#! allocates a Factor heap-local instance of this structure.
#! Used for C functions that expect you to pass in a struct.
[ <local-alien> ] cons
- <% "<" % "struct-name" get % ">" % %>
+ [ "<" , "struct-name" get , ">" , ] make-string
"in" get create swap
define-compound ;
: compilable-words ( -- list )
#! Make a list of all words that can be compiled.
reset-can-compile
- [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,]
+ [
+ [ dup can-compile? [ , ] [ drop ] ifte ] each-word
+ ] make-list
reset-can-compile ;
: cannot-compile ( word -- )
f>"" "doc-root" get swap cat2 ;
: file-response ( mime-type length -- )
- [,
+ [
unparse "Content-Length" swons ,
"Content-Type" swons ,
- ,] "200 OK" response terpri ;
+ ] make-list "200 OK" response terpri ;
: serve-static ( filename mime-type -- )
over file-length file-response "method" get "head" = [
! <a href= "http://" swap cat2 a> "click" write </a>
!
! (url -- )
-! <a href= <% "http://" % % %> a> "click" write </a>
+! <a href= [ "http://" , , ] make-string a> "click" write </a>
!
! Tags that have no 'closing' equivalent have a trailing tag/> form:
!
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
#! suitable for embedding in an html tag.
- reverse <% [ dup car % "='" % cdr % "'" % ] each %> ;
+ reverse [
+ [ dup car , "='" , cdr , "'" , ] each
+ ] make-string ;
: write-attributes ( n: namespace -- )
#! With the attribute namespace on the stack, get the attributes
: def-for-html-word-</foo> ( name -- name quot )
#! Return the name and code for the </foo> patterned
#! word.
- <% "</" % % ">" % %> dup [ write ] cons ;
+ [ "</" , , ">" , ] make-string dup [ write ] cons ;
: def-for-html-word-<foo/> ( name -- name quot )
#! Return the name and code for the <foo/> patterned
#! word.
- <% "<" % dup % "/>" % %> swap
- <% "<" % % ">" % %>
+ [ "<" , dup , "/>" , ] make-string swap
+ [ "<" , , ">" , ] make-string
[ write ] cons ;
: def-for-html-word-foo/> ( name -- name quot )
: >hex-color ( triplet -- hex )
[ >hex 2 digits ] map "#" swons cat ;
-: fg-css% ( color -- )
- "color: " % >hex-color % "; " % ;
+: fg-css, ( color -- )
+ "color: " , >hex-color , "; " , ;
-: bold-css% ( flag -- )
- [ "font-weight: bold; " % ] when ;
+: bold-css, ( flag -- )
+ [ "font-weight: bold; " , ] when ;
-: italics-css% ( flag -- )
- [ "font-style: italic; " % ] when ;
+: italics-css, ( flag -- )
+ [ "font-style: italic; " , ] when ;
-: underline-css% ( flag -- )
- [ "text-decoration: underline; " % ] when ;
+: underline-css, ( flag -- )
+ [ "text-decoration: underline; " , ] when ;
-: size-css% ( size -- )
- "font-size: " % unparse % "; " % ;
+: size-css, ( size -- )
+ "font-size: " , unparse , "; " , ;
-: font-css% ( font -- )
- "font-family: " % % "; " % ;
+: font-css, ( font -- )
+ "font-family: " , , "; " , ;
: css-style ( style -- )
- <% [
- [ "fg" fg-css% ]
- [ "bold" bold-css% ]
- [ "italics" italics-css% ]
- [ "underline" underline-css% ]
- [ "size" size-css% ]
- [ "font" font-css% ]
- ] assoc-apply %> ;
+ [
+ [
+ [ "fg" fg-css, ]
+ [ "bold" bold-css, ]
+ [ "italics" italics-css, ]
+ [ "underline" underline-css, ]
+ [ "size" size-css, ]
+ [ "font" font-css, ]
+ ] assoc-apply
+ ] make-string ;
: span-tag ( style quot -- )
over css-style dup "" = [
] when* "/" ?str-tail drop ;
: file-link-href ( path -- href )
- <% "/" % resolve-file-link url-encode % %> ;
+ [ "/" , resolve-file-link url-encode , ] make-string ;
: file-link-tag ( style quot -- )
over "file-link" swap assoc [
"301 Moved Permanently" response terpri ;
: directory-no/ ( -- )
- <% "request" get % CHAR: / %
- "raw-query" get [ CHAR: ? % % ] when*
- %> redirect ;
+ [
+ "request" get , CHAR: / ,
+ "raw-query" get [ CHAR: ? , , ] when*
+ ] make-string redirect ;
: header-line ( alist line -- alist )
": " split1 dup [ transp acons ] [ 2drop ] ifte ;
: log-user-agent ( alist -- )
"User-Agent" swap assoc* [
- unswons <% % ": " % % %> log
+ unswons [ , ": " , , ] make-string log
] when* ;
: prepare-url ( url -- url )
USE: combinators
USE: errors
USE: kernel
+USE: lists
USE: logic
USE: format
USE: math
2drop
] [
>r succ dup 2 + r> substring
- catch-hex> [ >char % ] when*
+ catch-hex> [ >char , ] when*
] ifte ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex >r 3 + r> ;
: url-decode-+-or-other ( index str ch -- index str )
- CHAR: + CHAR: \s replace % >r succ r> ;
+ CHAR: + CHAR: \s replace , >r succ r> ;
: url-decode-iter ( index str -- )
2dup str-length >= [
] ifte ;
: url-decode ( str -- str )
- <% 0 swap url-decode-iter %> ;
+ [ 0 swap url-decode-iter ] make-string ;
: run-user-init ( -- )
#! Run user init file if it exists
"user-init" get [
- <% "~" get % "/" get % ".factor-" % "rc" % %>
+ [ "~" get , "/" get , ".factor-" , "rc" , ] make-string
?run-file
] when ;
read parse-number
] with-stream ;
-: bool% ( ? -- str )
- "true" "false" ? % ;
+: bool, ( ? -- str )
+ "true" "false" ? , ;
-: list>bsh-array% ( list -- code )
- "new String[] {" %
- [ unparse % "," % ] each
- "null}" % ;
+: list>bsh-array, ( list -- code )
+ "new String[] {" ,
+ [ unparse , "," , ] each
+ "null}" , ;
: make-jedit-request ( files dir params -- code )
[
- <%
- "EditServer.handleClient(" %
- "restore" get bool% "," %
- "newView" get bool% "," %
- "newPlainView" get bool% "," %
- ( If the dir is not set, we don't want to send f )
- dup [ unparse ] [ drop "null" ] ifte % "," %
- list>bsh-array% ");\n" % %>
+ [
+ "EditServer.handleClient(" ,
+ "restore" get bool, "," ,
+ "newView" get bool, "," ,
+ "newPlainView" get bool, "," ,
+ ( If the dir is not set, we don't want to send f )
+ dup [ unparse ] [ drop "null" ] ifte , "," ,
+ list>bsh-array, ");\n" ,
+ ] make-string
] bind ;
: send-jedit-request ( request -- )
#! variable if it is not already contained in the list.
tuck get unique put ;
-: [, ( -- )
- #! Begin constructing a list.
- <namespace> >n f "list-buffer" set ;
+: make-rlist ( quot -- list )
+ #! Call a quotation. The quotation can call , to prepend
+ #! objects to the list that is returned when the quotation
+ #! is done.
+ [ "list-buffer" off call "list-buffer" get ] with-scope ;
+
+: make-list ( quot -- list )
+ #! Return a list whose entries are in the same order that ,
+ #! was called.
+ make-rlist reverse ;
: , ( obj -- )
#! Append an object to the currently constructing list.
#! Append an object to the currently constructing list, only
#! if the object does not already occur in the list.
"list-buffer" unique@ ;
-
-: ,] ( -- list )
- #! Finish constructing a list and push it on the stack.
- "list-buffer" get reverse n> drop ;
#! Destructively reverse a string buffer.
[ ] "java.lang.StringBuffer" "reverse" jinvoke drop ;
-DEFER: str>sbuf
+: str>sbuf ( str -- sbuf )
+ dup str-length <sbuf> tuck sbuf-append ;
+
: str-reverse ( str -- str )
str>sbuf dup sbuf-reverse sbuf>str ;
next-ch dup CHAR: " = [
drop
] [
- parse-ch % parse-string
+ parse-ch , parse-string
] ifte ;
: "
#! Note the ugly hack to carry the new value of 'pos' from
- #! the <% %> scope up to the original scope.
- <% parse-string "col" get %> swap "col" set parsed ; parsing
+ #! the make-string scope up to the original scope.
+ [ parse-string "col" get ] make-string
+ swap "col" set parsed ; parsing
! Complex literal
: #{
: stack-effect. ( word -- )
stack-effect [
" " write
- <% CHAR: ( % % CHAR: ) % %> prettyprint-comment
+ [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment
] when* ;
: documentation. ( indent word -- indent )
: call-counts. ( -- )
#! Print word/call count pairs.
- [, [ call-count, ] each-word ,] counts. ;
+ [ [ call-count, ] each-word ] make-list counts. ;
: profile-depth ( -- n )
only-top get [ -1 ] [ callstack vector-length ] ifte ;
: allot-counts. ( -- alist )
#! Print word/allot count pairs.
- [, [ allot-count, ] each-word ,] counts. ;
+ [ [ allot-count, ] each-word ] make-list counts. ;
: allot-profile ( quot -- )
#! Execute a quotation with the memory profiler enabled.
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
-: integer% ( num radix -- )
- tuck /mod >digit % dup 0 > [
- swap integer%
+: integer, ( num radix -- )
+ tuck /mod >digit , dup 0 > [
+ swap integer,
] [
2drop
] ifte ;
-: integer- ( num -- num )
- dup 0 < [ "-" % neg ] when ;
-
: >base ( num radix -- string )
#! Convert a number to a string in a certain base.
- <% over 0 < [
- swap neg swap integer% CHAR: - %
- ] [
- integer%
- ] ifte reverse%> ;
+ [
+ over 0 < [
+ swap neg swap integer, CHAR: - ,
+ ] [
+ integer,
+ ] ifte
+ ] make-rstring ;
: >dec ( num -- string ) 10 >base ;
: >bin ( num -- string ) 2 >base ;
DEFER: unparse
: unparse-ratio ( num -- str )
- <% dup
- numerator unparse %
- CHAR: / %
- denominator unparse % %> ;
+ [
+ dup
+ numerator unparse ,
+ CHAR: / ,
+ denominator unparse ,
+ ] make-string ;
: unparse-complex ( num -- str )
- >rect <% "#{ " % swap unparse % " " % unparse % " }" % %> ;
+ [
+ "#{ " ,
+ dup
+ real unparse ,
+ " " ,
+ imaginary unparse ,
+ " }" ,
+ ] make-string ;
: ch>ascii-escape ( ch -- esc )
[
] unless ;
: unparse-str ( str -- str )
- <% CHAR: " % [ unparse-ch % ] str-each CHAR: " % %> ;
+ [
+ CHAR: " , [ unparse-ch , ] str-each CHAR: " ,
+ ] make-string ;
: unparse-word ( word -- str )
word-name dup "#<unnamed>" ? ;
: unparse-float ( float -- str ) (unparse-float) fix-float ;
: unparse-unknown ( obj -- str )
- <% "#<" %
- dup type type-name %
- " @ " %
- address unparse %
- ">" % %> ;
+ [
+ "#<" ,
+ dup type type-name ,
+ " @ " ,
+ address unparse ,
+ ">" ,
+ ] make-string ;
: unparse-t drop "t" ;
: unparse-f drop "f" ;
trim-newline "comments" style write-attr ;
: word-link ( word -- link )
- <%
- "vocabularies'" %
- dup word-vocabulary %
- "'" %
- word-name %
- %> ;
+ [
+ "vocabularies'" ,
+ dup word-vocabulary ,
+ "'" ,
+ word-name ,
+ ] make-string ;
: word-actions ( -- list )
[
0 swap prettyprint* drop terpri ;
: vocab-link ( vocab -- link )
- <% "vocabularies'" % % %> ;
+ "vocabularies'" swap cat2 ;
: vocab-attrs ( word -- attrs )
vocab-link "object-link" default-style acons ;
#! Returns a random subset of the given list of comma pairs.
#! The car of each pair is a probability, the cdr is the
#! item itself. Only the cdr of the comma pair is returned.
- [,
+ [
[ car+ ] keep ( probabilitySum list )
[
>r 1 over random-int r> ( probabilitySum probability elem )
> ( probabilitySum elemd boolean )
[ drop ] [ , ] ifte
] each drop
- ,] ;
+ ] make-list ;
USE: strings
USE: stack
-: str>sbuf ( str -- sbuf )
- dup str-length <sbuf> tuck sbuf-append ;
+: make-string ( quot -- string )
+ #! Call a quotation. The quotation can call , to prepend
+ #! objects to the list that is returned when the quotation
+ #! is done.
+ make-list cat ;
-: string-buffer-size 80 ;
-
-: <% ( -- )
- #! Begins constructing a string.
- <namespace> >n string-buffer-size <sbuf>
- "string-buffer" set ;
-
-: % ( str -- )
- #! Append a string to the construction buffer.
- "string-buffer" get sbuf-append ;
-
-: %> ( -- str )
- #! Ends construction and pushes the constructed text on the
- #! stack.
- "string-buffer" get sbuf>str n> drop ;
-
-: reverse%> ( -- str )
- #! Ends construction and pushes the *reversed*, constructed
- #! text on the stack.
- "string-buffer" get dup sbuf-reverse sbuf>str n> drop ;
+: make-rstring ( quot -- string )
+ #! Return a string whose entries are in the same order that ,
+ #! was called.
+ make-rlist cat ;
: fill ( count char -- string )
#! Push a string that consists of the same character
#! repeated.
- <% swap [ dup % ] times drop %> ;
+ [ swap [ dup , ] times drop ] make-string ;
: str-map ( str code -- str )
#! Apply a quotation to each character in the string, and
: split ( string split -- list )
#! Split the string at each occurrence of split, and push a
#! list of the pieces.
- [, 0 -rot (split) ,] ;
+ [ 0 -rot (split) ] make-list ;
: split-n-advance substring , >r tuck + swap r> ;
: split-n-finish nip dup str-length swap substring , ;
: split-n ( n str -- list )
#! Split a string into n-character chunks.
- [, 0 -rot (split-n) ,] ;
+ [ 0 -rot (split-n) ] make-list ;
USE: stack
USE: test
-[ ] [ [, 100000 [ 0 10000 random-int , ] times ,] num-sort drop ] unit-test
+[ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list num-sort drop ] unit-test
USE: math
USE: combinators
USE: test
+USE: lists
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
: string-step ( n str -- )
2dup str-length > [
- dup <% "123" % % "456" % % "789" % %>
+ dup [ "123" , , "456" , , "789" , ] make-string
dup dup str-length 2 /i 0 transp substring
swap dup str-length 2 /i succ 1 transp substring cat2
string-step
[ drop ] [ drop ] catch
] keep-datastack
-"hello" str>sbuf "x" set
-[ -5 "x" get set-sbuf-length ] [ drop ] catch
-[ "x" get sbuf>str drop ] [ drop ] catch
-
10 <vector> "x" set
[ -2 "x" get set-vector-length ] [ drop ] catch
[ "x" get vector-clone drop ] [ drop ] catch
] unit-test
[ [ "xyz" #{ 3 2 } 1/5 [ { } ] ] ] [
- [, "xyz" , "xyz" unique,
+ [ "xyz" , "xyz" unique,
#{ 3 2 } , #{ 3 2 } unique,
1/5 , 1/5 unique,
- [, { } unique, ,] , ,]
+ [ { } unique, ] make-list , ] make-list
] unit-test
USE: strings
USE: test
-[ t ] [ "Foo" str>sbuf "Foo" str>sbuf = ] unit-test
-[ f ] [ "Foo" str>sbuf "Foob" str>sbuf = ] unit-test
-[ f ] [ 34 "Foo" str>sbuf = ] unit-test
-
[ "Hello" ] [
100 <sbuf> "buf" set
"Hello" "buf" get sbuf-append
"World" "buf-clone" get sbuf-append
"buf" get sbuf>str
] unit-test
-
-[ t ] [
- "Hello world" str>sbuf hashcode
- "Hello world" hashcode =
-] unit-test
USE: combinators
USE: continuations
USE: kernel
+USE: lists
USE: logic
USE: namespaces
USE: prettyprint
"ERROR: " write error. ;
: parse-dump ( error -- )
- <%
- "error-file" get [ "<interactive>" ] unless* % ":" %
- "error-line-number" get [ 1 ] unless* unparse % ": " %
- %> write
+ [
+ "error-file" get [ "<interactive>" ] unless* , ":" ,
+ "error-line-number" get [ 1 ] unless* unparse , ": " ,
+ ] make-string write
error.
"error-line" get print
- <% "error-col" get " " fill % "^" % %> print ;
+ [ "error-col" get " " fill , "^" , ] make-string print ;
: in-parser? ( -- ? )
"error-line" get "error-col" get and ;
(vocabulary) set-hash ;
: 'plist ( word -- plist )
- [,
-
- dup word-name "name" swons ,
- dup word-vocabulary "vocabulary" swons ,
- "parsing" word-property [ t "parsing" swons , ] when
-
- ,] ' ;
+ [
+ dup word-name "name" swons ,
+ dup word-vocabulary "vocabulary" swons ,
+ "parsing" word-property [ t "parsing" swons , ] when
+ ] make-list ' ;
: (worddef,) ( word primitive parameter -- )
' >r >r dup (word+) dup 'plist >r
USE: vectors
: print-banner ( -- )
- <% "This is " % java? [ "JVM " % ] when
- native? [ "native " % ] when "Factor " % version % %> print
+ [
+ "This is " ,
+ java? [ "JVM " , ] when
+ native? [ "native " , ] when
+ "Factor " , version ,
+ ] make-string print
"Copyright (C) 2003, 2004 Slava Pestov" print
"Copyright (C) 2004 Chris Double" print
"Type ``exit'' to exit, ``help'' for help." print ;
: vocabs ( -- list )
#! Push a list of vocabularies.
- global [ "vocabularies" get [ vars ] bind ] bind ;
+ global [ "vocabularies" get [ vars str-sort ] bind ] bind ;
: vocab ( name -- vocab )
#! Get a vocabulary.
global [ "vocabularies" get get* ] bind ;
+: word-sort ( list -- list )
+ #! Sort a list of words by name.
+ [ swap word-name swap word-name str-lexi> ] sort ;
+
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
- vocab [ values ] bind [ ] subset ;
+ vocab [ values ] bind [ ] subset word-sort ;
: init-search-path ( -- )
! For files
projects / factor.git / commitdiff