Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
f62847a430
|
|
@ -515,7 +515,7 @@ M: quotation '
|
|||
20000 <hashtable> objects set
|
||||
emit-header t, 0, 1, -1,
|
||||
"Building generic words..." print flush
|
||||
call-remake-generics-hook
|
||||
remake-generics
|
||||
"Serializing words..." print flush
|
||||
emit-words
|
||||
"Serializing JIT data..." print flush
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ HELP: month-name
|
|||
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
|
||||
HELP: month-abbreviations
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the English abbreviated names of all the months." }
|
||||
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ HELP: day-name
|
|||
{ $description "Looks up the day name and returns it as a string." } ;
|
||||
|
||||
HELP: day-abbreviations2
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
|
||||
|
||||
HELP: day-abbreviation2
|
||||
|
|
@ -62,7 +62,7 @@ HELP: day-abbreviation2
|
|||
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
|
||||
|
||||
HELP: day-abbreviations3
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
|
||||
|
||||
HELP: day-abbreviation3
|
||||
|
|
|
|||
|
|
@ -39,8 +39,10 @@ M: not-a-month summary
|
|||
drop "Months are indexed starting at 1" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: check-month ( n -- n )
|
||||
dup zero? [ not-a-month ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: month-names ( -- array )
|
||||
|
|
@ -52,11 +54,11 @@ PRIVATE>
|
|||
: month-name ( n -- string )
|
||||
check-month 1- month-names nth ;
|
||||
|
||||
: month-abbreviations ( -- array )
|
||||
CONSTANT: month-abbreviations
|
||||
{
|
||||
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
|
||||
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
|
||||
} ;
|
||||
}
|
||||
|
||||
: month-abbreviation ( n -- string )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
|
|
@ -70,17 +72,17 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
|||
|
||||
: day-name ( n -- string ) day-names nth ;
|
||||
|
||||
: day-abbreviations2 ( -- array )
|
||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
|
||||
CONSTANT: day-abbreviations2
|
||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
|
||||
|
||||
: day-abbreviation2 ( n -- string )
|
||||
day-abbreviations2 nth ;
|
||||
day-abbreviations2 nth ; inline
|
||||
|
||||
: day-abbreviations3 ( -- array )
|
||||
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
|
||||
CONSTANT: day-abbreviations3
|
||||
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
|
||||
|
||||
: day-abbreviation3 ( n -- string )
|
||||
day-abbreviations3 nth ;
|
||||
day-abbreviations3 nth ; inline
|
||||
|
||||
: average-month ( -- ratio ) 30+5/12 ; inline
|
||||
: months-per-year ( -- integer ) 12 ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
|||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||
{ $subsection disable-compiler }
|
||||
{ $subsection enable-compiler }
|
||||
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
|
||||
{ $subsection optimized-recompile-hook }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"Compiling a single quotation:"
|
||||
|
|
@ -46,9 +44,8 @@ HELP: (compile)
|
|||
{ $description "Compile a single word." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: optimized-recompile-hook
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
|
||||
{ $description "Compile a set of words." }
|
||||
HELP: optimizing-compiler
|
||||
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: compile-call
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ t compile-dependencies? set-global
|
|||
] with-return ;
|
||||
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield-hook get call ] slurp-deque ;
|
||||
[ (compile) yield-hook get assert-depth ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array modify-code-heap ;
|
||||
|
|
@ -119,7 +119,9 @@ t compile-dependencies? set-global
|
|||
: compile-call ( quot -- )
|
||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||
|
||||
: optimized-recompile-hook ( words -- alist )
|
||||
SINGLETON: optimizing-compiler
|
||||
|
||||
M: optimizing-compiler recompile ( words -- alist )
|
||||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
H{ } clone compiled set
|
||||
|
|
@ -129,10 +131,10 @@ t compile-dependencies? set-global
|
|||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ optimized-recompile-hook ] recompile-hook set-global ;
|
||||
optimizing-compiler compiler-impl set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
f compiler-impl set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
forget-errors all-words compile ;
|
||||
|
|
|
|||
|
|
@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
|
|||
check_sse2 ;
|
||||
|
||||
"-no-sse2" (command-line) member? [
|
||||
[ optimized-recompile-hook ] recompile-hook
|
||||
[ { check_sse2 } compile ] with-variable
|
||||
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
|
||||
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
|||
|
|
@ -1,18 +1,15 @@
|
|||
USING: images.bitmap images.viewer io.encodings.binary
|
||||
io.files io.files.unique kernel tools.test images.loader ;
|
||||
io.files io.files.unique kernel tools.test images.loader
|
||||
literals sequences ;
|
||||
IN: images.bitmap.tests
|
||||
|
||||
: test-bitmap24 ( -- path )
|
||||
"vocab:images/test-images/thiswayup24.bmp" ;
|
||||
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
|
||||
|
||||
: test-bitmap8 ( -- path )
|
||||
"vocab:images/test-images/rgb8bit.bmp" ;
|
||||
CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp"
|
||||
|
||||
: test-bitmap4 ( -- path )
|
||||
"vocab:images/test-images/rgb4bit.bmp" ;
|
||||
CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
|
||||
|
||||
: test-bitmap1 ( -- path )
|
||||
"vocab:images/test-images/1bit.bmp" ;
|
||||
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
|
||||
|
||||
[ t ]
|
||||
[
|
||||
|
|
@ -22,3 +19,9 @@ IN: images.bitmap.tests
|
|||
"test-bitmap24" unique-file
|
||||
[ save-bitmap ] [ binary file-contents ] bi =
|
||||
] unit-test
|
||||
|
||||
{
|
||||
$ test-bitmap8
|
||||
$ test-bitmap24
|
||||
"vocab:ui/render/test/reference.bmp"
|
||||
} [ [ ] swap [ load-image drop ] curry unit-test ] each
|
||||
|
|
@ -3,17 +3,26 @@
|
|||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||
combinators fry grouping io io.binary io.encodings.binary io.files
|
||||
kernel macros math math.bitwise math.functions namespaces sequences
|
||||
strings images endian summary ;
|
||||
strings images endian summary locals ;
|
||||
IN: images.bitmap
|
||||
|
||||
TUPLE: bitmap-image < image
|
||||
magic size reserved offset header-length width
|
||||
: assert-sequence= ( a b -- )
|
||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
||||
|
||||
: read2 ( -- n ) 2 read le> ;
|
||||
: read4 ( -- n ) 4 read le> ;
|
||||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
|
||||
TUPLE: bitmap-image < image ;
|
||||
|
||||
! Used to construct the final bitmap-image
|
||||
|
||||
TUPLE: loading-bitmap
|
||||
size reserved offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important rgb-quads color-index ;
|
||||
|
||||
! Currently can only handle 24/32bit bitmaps.
|
||||
! Handles row-reversed bitmaps (their height is negative)
|
||||
|
||||
ERROR: bitmap-magic magic ;
|
||||
|
||||
M: bitmap-magic summary
|
||||
|
|
@ -21,40 +30,34 @@ M: bitmap-magic summary
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: array-copy ( bitmap array -- bitmap array' )
|
||||
over size-image>> abs memory>byte-array ;
|
||||
|
||||
: 8bit>buffer ( bitmap -- array )
|
||||
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
||||
|
||||
ERROR: bmp-not-supported n ;
|
||||
|
||||
: raw-bitmap>buffer ( bitmap -- array )
|
||||
: reverse-lines ( byte-array width -- byte-array )
|
||||
3 * <sliced-groups> <reversed> concat ; inline
|
||||
|
||||
: raw-bitmap>seq ( loading-bitmap -- array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ color-index>> ] }
|
||||
{ 16 [ bmp-not-supported ] }
|
||||
{ 8 [ 8bit>buffer ] }
|
||||
{ 4 [ bmp-not-supported ] }
|
||||
{ 2 [ bmp-not-supported ] }
|
||||
{ 1 [ bmp-not-supported ] }
|
||||
{ 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
|
||||
{ 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
|
||||
[ bmp-not-supported ]
|
||||
} case >byte-array ;
|
||||
|
||||
: read2 ( -- n ) 2 read le> ;
|
||||
: read4 ( -- n ) 4 read le> ;
|
||||
|
||||
: parse-file-header ( bitmap -- bitmap )
|
||||
2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
|
||||
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
||||
2 read "BM" assert-sequence=
|
||||
read4 >>size
|
||||
read4 >>reserved
|
||||
read4 >>offset ;
|
||||
|
||||
: parse-bitmap-header ( bitmap -- bitmap )
|
||||
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 >>header-length
|
||||
read4 >>width
|
||||
read4 >>height
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count
|
||||
read4 >>compression
|
||||
|
|
@ -64,10 +67,10 @@ ERROR: bmp-not-supported n ;
|
|||
read4 >>color-used
|
||||
read4 >>color-important ;
|
||||
|
||||
: rgb-quads-length ( bitmap -- n )
|
||||
: rgb-quads-length ( loading-bitmap -- n )
|
||||
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
||||
|
||||
: color-index-length ( bitmap -- n )
|
||||
: color-index-length ( loading-bitmap -- n )
|
||||
{
|
||||
[ width>> ]
|
||||
[ planes>> * ]
|
||||
|
|
@ -75,21 +78,37 @@ ERROR: bmp-not-supported n ;
|
|||
[ height>> abs * ]
|
||||
} cleave ;
|
||||
|
||||
: parse-bitmap ( bitmap -- bitmap )
|
||||
dup rgb-quads-length read >>rgb-quads
|
||||
dup color-index-length read >>color-index ;
|
||||
: image-size ( loading-bitmap -- n )
|
||||
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
|
||||
|
||||
: load-bitmap-data ( path bitmap -- bitmap )
|
||||
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
|
||||
loading-bitmap width>> :> width
|
||||
loading-bitmap height>> abs :> height
|
||||
loading-bitmap color-index>> length :> color-index-length
|
||||
height 3 * :> height*3
|
||||
color-index-length width height*3 * - height*3 /i :> misaligned
|
||||
misaligned 0 > [
|
||||
loading-bitmap [
|
||||
loading-bitmap width>> misaligned + 3 * <sliced-groups>
|
||||
[ 3 misaligned * head* ] map concat
|
||||
] change-color-index
|
||||
] [
|
||||
loading-bitmap
|
||||
] if ;
|
||||
|
||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup rgb-quads-length read >>rgb-quads
|
||||
dup color-index-length read >>color-index
|
||||
fixup-color-index ;
|
||||
|
||||
: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
|
||||
[ binary ] dip '[
|
||||
_ parse-file-header parse-bitmap-header parse-bitmap
|
||||
] with-file-reader ;
|
||||
|
||||
: process-bitmap-data ( bitmap -- bitmap )
|
||||
dup raw-bitmap>buffer >>bitmap ;
|
||||
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
|
||||
: bitmap>component-order ( bitmap -- object )
|
||||
: bitmap>component-order ( loading-bitmap -- object )
|
||||
bit-count>> {
|
||||
{ 32 [ BGRA ] }
|
||||
{ 24 [ BGR ] }
|
||||
|
|
@ -97,61 +116,67 @@ ERROR: unknown-component-order bitmap ;
|
|||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: fill-image-slots ( bitmap -- bitmap )
|
||||
dup {
|
||||
[ [ width>> ] [ height>> ] bi 2array >>dim ]
|
||||
: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
|
||||
[ bitmap-image new ] dip
|
||||
{
|
||||
[ raw-bitmap>seq >>bitmap ]
|
||||
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||
[ height>> 0 < [ t >>upside-down? ] when ]
|
||||
[ bitmap>component-order >>component-order ]
|
||||
[ bitmap>> >>bitmap ]
|
||||
} cleave ;
|
||||
|
||||
M: bitmap-image load-image* ( path bitmap -- bitmap )
|
||||
load-bitmap-data process-bitmap-data
|
||||
fill-image-slots ;
|
||||
|
||||
MACRO: (nbits>bitmap) ( bits -- )
|
||||
[ -3 shift ] keep '[
|
||||
bitmap-image new
|
||||
2over * _ * >>size-image
|
||||
swap >>height
|
||||
swap >>width
|
||||
swap array-copy [ >>bitmap ] [ >>color-index ] bi
|
||||
_ >>bit-count fill-image-slots
|
||||
t >>upside-down?
|
||||
] ;
|
||||
|
||||
: bgr>bitmap ( array height width -- bitmap )
|
||||
24 (nbits>bitmap) ;
|
||||
|
||||
: bgra>bitmap ( array height width -- bitmap )
|
||||
32 (nbits>bitmap) ;
|
||||
|
||||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
||||
drop loading-bitmap new
|
||||
load-bitmap-data
|
||||
loading-bitmap>bitmap-image ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: save-bitmap ( bitmap path -- )
|
||||
: bitmap>color-index ( bitmap-array -- byte-array )
|
||||
4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
|
||||
|
||||
: save-bitmap ( image path -- )
|
||||
binary [
|
||||
B{ CHAR: B CHAR: M } write
|
||||
[
|
||||
color-index>> length 14 + 40 + write4
|
||||
bitmap>> bitmap>color-index length 14 + 40 + write4
|
||||
0 write4
|
||||
54 write4
|
||||
40 write4
|
||||
] [
|
||||
{
|
||||
[ width>> write4 ]
|
||||
[ height>> write4 ]
|
||||
[ planes>> 1 or write2 ]
|
||||
[ bit-count>> 24 or write2 ]
|
||||
[ compression>> 0 or write4 ]
|
||||
[ size-image>> write4 ]
|
||||
[ x-pels>> 0 or write4 ]
|
||||
[ y-pels>> 0 or write4 ]
|
||||
[ color-used>> 0 or write4 ]
|
||||
[ color-important>> 0 or write4 ]
|
||||
[ rgb-quads>> write ]
|
||||
[ color-index>> write ]
|
||||
! width height
|
||||
[ dim>> first2 [ write4 ] bi@ ]
|
||||
|
||||
! planes
|
||||
[ drop 1 write2 ]
|
||||
|
||||
! bit-count
|
||||
[ drop 24 write2 ]
|
||||
|
||||
! compression
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! size-image
|
||||
[ bitmap>> bitmap>color-index length write4 ]
|
||||
|
||||
! x-pels
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! y-pels
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! color-used
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! color-important
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! rgb-quads
|
||||
[
|
||||
[ bitmap>> bitmap>color-index ] [ dim>> first ] bi
|
||||
reverse-lines write
|
||||
]
|
||||
} cleave
|
||||
] bi
|
||||
] with-file-writer ;
|
||||
|
|
|
|||
|
|
@ -61,26 +61,30 @@ M: R16G16B16A16 normalize-component-order*
|
|||
M: R16G16B16 normalize-component-order*
|
||||
drop RGB16>8 add-dummy-alpha ;
|
||||
|
||||
: BGR>RGB ( bitmap bytes-per-pixel -- pixels )
|
||||
<groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
|
||||
: BGR>RGB ( bitmap -- pixels )
|
||||
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
|
||||
|
||||
: BGRA>RGBA ( bitmap -- pixels )
|
||||
4 <sliced-groups>
|
||||
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
|
||||
|
||||
M: BGRA normalize-component-order*
|
||||
drop 4 BGR>RGB ;
|
||||
drop BGRA>RGBA ;
|
||||
|
||||
M: RGB normalize-component-order*
|
||||
drop add-dummy-alpha ;
|
||||
|
||||
M: BGR normalize-component-order*
|
||||
drop 3 BGR>RGB add-dummy-alpha ;
|
||||
drop BGR>RGB add-dummy-alpha ;
|
||||
|
||||
: ARGB>RGBA ( bitmap -- bitmap' )
|
||||
4 <groups> [ unclip suffix ] map B{ } join ;
|
||||
4 <groups> [ unclip suffix ] map B{ } join ; inline
|
||||
|
||||
M: ARGB normalize-component-order*
|
||||
drop ARGB>RGBA ;
|
||||
|
||||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA 4 BGR>RGB ;
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
|
|
|
|||
|
|
@ -2,15 +2,18 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors constructors images io io.binary io.encodings.ascii
|
||||
io.encodings.binary io.encodings.string io.files io.files.info kernel
|
||||
sequences io.streams.limited ;
|
||||
sequences io.streams.limited fry combinators arrays math
|
||||
checksums checksums.crc32 ;
|
||||
IN: images.png
|
||||
|
||||
TUPLE: png-image < image chunks ;
|
||||
TUPLE: png-image < image chunks
|
||||
width height bit-depth color-type compression-method
|
||||
filter-method interlace-method uncompressed ;
|
||||
|
||||
CONSTRUCTOR: png-image ( -- image )
|
||||
V{ } clone >>chunks ;
|
||||
|
||||
TUPLE: png-chunk length type data crc ;
|
||||
TUPLE: png-chunk length type data ;
|
||||
|
||||
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
|
||||
|
||||
|
|
@ -23,19 +26,47 @@ ERROR: bad-png-header header ;
|
|||
bad-png-header
|
||||
] unless drop ;
|
||||
|
||||
ERROR: bad-checksum ;
|
||||
|
||||
: read-png-chunks ( image -- image )
|
||||
<png-chunk>
|
||||
4 read be> >>length
|
||||
4 read ascii decode >>type
|
||||
dup length>> read >>data
|
||||
4 read >>crc
|
||||
4 read be> [ >>length ] [ 4 + ] bi
|
||||
read dup crc32 checksum-bytes
|
||||
4 read = [ bad-checksum ] unless
|
||||
4 cut-slice
|
||||
[ ascii decode >>type ]
|
||||
[ B{ } like >>data ] bi*
|
||||
[ over chunks>> push ]
|
||||
[ type>> ] bi "IEND" =
|
||||
[ read-png-chunks ] unless ;
|
||||
|
||||
: find-chunk ( image string -- chunk )
|
||||
[ chunks>> ] dip '[ type>> _ = ] find nip ;
|
||||
|
||||
: parse-ihdr-chunk ( image -- image )
|
||||
dup "IHDR" find-chunk data>> {
|
||||
[ [ 0 4 ] dip subseq be> >>width ]
|
||||
[ [ 4 8 ] dip subseq be> >>height ]
|
||||
[ [ 8 ] dip nth >>bit-depth ]
|
||||
[ [ 9 ] dip nth >>color-type ]
|
||||
[ [ 10 ] dip nth >>compression-method ]
|
||||
[ [ 11 ] dip nth >>filter-method ]
|
||||
[ [ 12 ] dip nth >>interlace-method ]
|
||||
} cleave ;
|
||||
|
||||
: find-compressed-bytes ( image -- bytes )
|
||||
chunks>> [ type>> "IDAT" = ] filter
|
||||
[ data>> ] map concat ;
|
||||
|
||||
: fill-image-data ( image -- image )
|
||||
dup [ width>> ] [ height>> ] bi 2array >>dim ;
|
||||
|
||||
: load-png ( path -- image )
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi stream-throws <limited-stream> [
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi
|
||||
stream-throws <limited-stream> [
|
||||
<png-image>
|
||||
read-png-header
|
||||
read-png-chunks
|
||||
parse-ihdr-chunk
|
||||
fill-image-data
|
||||
] with-input-stream ;
|
||||
|
|
|
|||
|
|
@ -27,6 +27,8 @@ TUPLE: buffered-port < port { buffer buffer } ;
|
|||
|
||||
TUPLE: input-port < buffered-port ;
|
||||
|
||||
M: input-port stream-element-type drop +byte+ ;
|
||||
|
||||
: <input-port> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
||||
|
|
@ -102,6 +104,8 @@ TUPLE: output-port < buffered-port ;
|
|||
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
|
||||
[ drop ] [ stream-flush ] if ; inline
|
||||
|
||||
M: output-port stream-element-type stream>> stream-element-type ;
|
||||
|
||||
M: output-port stream-write1
|
||||
dup check-disposed
|
||||
1 over wait-to-write
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ sequences io namespaces io.encodings.private accessors sequences.private
|
|||
io.streams.sequence destructors math combinators ;
|
||||
IN: io.streams.byte-array
|
||||
|
||||
M: byte-vector stream-element-type drop +byte+ ;
|
||||
|
||||
: <byte-writer> ( encoding -- stream )
|
||||
512 <byte-vector> swap <encoder> ;
|
||||
|
||||
|
|
@ -14,6 +16,8 @@ IN: io.streams.byte-array
|
|||
|
||||
TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
|
||||
|
||||
M: byte-reader stream-element-type drop +byte+ ;
|
||||
|
||||
M: byte-reader stream-read-partial stream-read ;
|
||||
M: byte-reader stream-read sequence-read ;
|
||||
M: byte-reader stream-read1 sequence-read1 ;
|
||||
|
|
|
|||
|
|
@ -15,6 +15,11 @@ CONSULT: formatted-output-stream-protocol duplex-stream out>> ;
|
|||
|
||||
: >duplex-stream< ( stream -- in out ) [ in>> ] [ out>> ] bi ; inline
|
||||
|
||||
M: duplex-stream stream-element-type
|
||||
[ in>> ] [ out>> ] bi
|
||||
[ stream-element-type ] bi@
|
||||
2dup eq? [ drop ] [ "Cannot determine element type" throw ] if ;
|
||||
|
||||
M: duplex-stream set-timeout
|
||||
>duplex-stream< [ set-timeout ] bi-curry@ bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,8 @@ TUPLE: memory-stream alien index ;
|
|||
: <memory-stream> ( alien -- stream )
|
||||
0 memory-stream boa ;
|
||||
|
||||
M: memory-stream stream-element-type drop +byte+ ;
|
||||
|
||||
M: memory-stream stream-read1
|
||||
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
|
||||
[ [ 1+ ] change-index drop ] bi ;
|
||||
|
|
|
|||
|
|
@ -5,41 +5,33 @@ strings generic splitting continuations destructors sequences.private
|
|||
io.streams.plain io.encodings math.order growable io.streams.sequence ;
|
||||
IN: io.streams.string
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SINGLETON: null-encoding
|
||||
|
||||
M: null-encoding decode-char drop stream-read1 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: growable dispose drop ;
|
||||
|
||||
M: growable stream-write1 push ;
|
||||
M: growable stream-write push-all ;
|
||||
M: growable stream-flush drop ;
|
||||
|
||||
: <string-writer> ( -- stream )
|
||||
512 <sbuf> ;
|
||||
|
||||
: with-string-writer ( quot -- str )
|
||||
<string-writer> swap [ output-stream get ] compose with-output-stream*
|
||||
>string ; inline
|
||||
|
||||
! New implementation
|
||||
|
||||
! Readers
|
||||
TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
|
||||
|
||||
M: string-reader stream-element-type drop +character+ ;
|
||||
M: string-reader stream-read-partial stream-read ;
|
||||
M: string-reader stream-read sequence-read ;
|
||||
M: string-reader stream-read1 sequence-read1 ;
|
||||
M: string-reader stream-read-until sequence-read-until ;
|
||||
M: string-reader dispose drop ;
|
||||
|
||||
<PRIVATE
|
||||
SINGLETON: null-encoding
|
||||
M: null-encoding decode-char drop stream-read1 ;
|
||||
PRIVATE>
|
||||
|
||||
: <string-reader> ( str -- stream )
|
||||
0 string-reader boa null-encoding <decoder> ;
|
||||
|
||||
: with-string-reader ( str quot -- )
|
||||
[ <string-reader> ] dip with-input-stream ; inline
|
||||
|
||||
INSTANCE: growable plain-writer
|
||||
! Writers
|
||||
M: sbuf stream-element-type drop +character+ ;
|
||||
|
||||
: <string-writer> ( -- stream )
|
||||
512 <sbuf> ;
|
||||
|
||||
: with-string-writer ( quot -- str )
|
||||
<string-writer> swap [ output-stream get ] compose with-output-stream*
|
||||
>string ; inline
|
||||
|
|
@ -48,6 +48,8 @@ CONSULT: output-stream-protocol filter-writer stream>> ;
|
|||
|
||||
CONSULT: formatted-output-stream-protocol filter-writer stream>> ;
|
||||
|
||||
M: filter-writer stream-element-type stream>> stream-element-type ;
|
||||
|
||||
M: filter-writer dispose stream>> dispose ;
|
||||
|
||||
TUPLE: ignore-close-stream < filter-writer ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ ARTICLE: { "lists" "protocol" } "The list protocol"
|
|||
{ $subsection cdr }
|
||||
{ $subsection nil? } ;
|
||||
|
||||
ARTICLE: { "lists" "strict" } "Strict lists"
|
||||
ARTICLE: { "lists" "strict" } "Constructing strict lists"
|
||||
"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:"
|
||||
{ $subsection cons }
|
||||
{ $subsection swons }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs
|
|||
continuations peg peg.parsers unicode.categories multiline
|
||||
splitting accessors effects sequences.deep peg.search
|
||||
combinators.short-circuit lexer io.streams.string stack-checker
|
||||
io combinators parser ;
|
||||
io combinators parser call ;
|
||||
IN: peg.ebnf
|
||||
|
||||
: rule ( name word -- parser )
|
||||
|
|
@ -36,7 +36,7 @@ TUPLE: tokenizer any one many ;
|
|||
|
||||
: TOKENIZER:
|
||||
scan search [ "Tokenizer not found" throw ] unless*
|
||||
execute \ tokenizer set-global ; parsing
|
||||
execute( -- tokenizer ) \ tokenizer set-global ; parsing
|
||||
|
||||
TUPLE: ebnf-non-terminal symbol ;
|
||||
TUPLE: ebnf-terminal symbol ;
|
||||
|
|
@ -391,7 +391,7 @@ M: ebnf-choice (transform) ( ast -- parser )
|
|||
options>> [ (transform) ] map choice ;
|
||||
|
||||
M: ebnf-any-character (transform) ( ast -- parser )
|
||||
drop tokenizer any>> call ;
|
||||
drop tokenizer any>> call( -- parser ) ;
|
||||
|
||||
M: ebnf-range (transform) ( ast -- parser )
|
||||
pattern>> range-pattern ;
|
||||
|
|
@ -469,17 +469,17 @@ ERROR: bad-effect quot effect ;
|
|||
|
||||
M: ebnf-action (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
|
||||
string-lines parse-lines check-action-effect action ;
|
||||
[ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
|
||||
|
||||
M: ebnf-semantic (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
|
||||
string-lines parse-lines semantic ;
|
||||
[ string-lines parse-lines ] call( string -- quot ) semantic ;
|
||||
|
||||
M: ebnf-var (transform) ( ast -- parser )
|
||||
parser>> (transform) ;
|
||||
|
||||
M: ebnf-terminal (transform) ( ast -- parser )
|
||||
symbol>> tokenizer one>> call ;
|
||||
symbol>> tokenizer one>> call( symbol -- parser ) ;
|
||||
|
||||
M: ebnf-foreign (transform) ( ast -- parser )
|
||||
dup word>> search
|
||||
|
|
@ -487,7 +487,7 @@ M: ebnf-foreign (transform) ( ast -- parser )
|
|||
swap rule>> [ main ] unless* over rule [
|
||||
nip
|
||||
] [
|
||||
execute
|
||||
execute( -- parser )
|
||||
] if* ;
|
||||
|
||||
: parser-not-found ( name -- * )
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ USING: kernel tools.test strings namespaces make arrays sequences
|
|||
peg peg.private peg.parsers accessors words math accessors ;
|
||||
IN: peg.tests
|
||||
|
||||
\ parse must-infer
|
||||
|
||||
[ ] [ reset-pegs ] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
|
|||
io vectors arrays math.parser math.order vectors combinators
|
||||
classes sets unicode.categories compiler.units parser words
|
||||
quotations effects memoize accessors locals effects splitting
|
||||
combinators.short-circuit generalizations ;
|
||||
combinators.short-circuit generalizations call ;
|
||||
IN: peg
|
||||
|
||||
TUPLE: parse-result remaining ast ;
|
||||
|
|
@ -298,7 +298,7 @@ SYMBOL: delayed
|
|||
#! Work through all delayed parsers and recompile their
|
||||
#! words to have the correct bodies.
|
||||
delayed get [
|
||||
call compile-parser 1quotation (( -- result )) define-declared
|
||||
call( -- parser ) compile-parser 1quotation (( -- result )) define-declared
|
||||
] assoc-each ;
|
||||
|
||||
: compile ( parser -- word )
|
||||
|
|
@ -309,7 +309,7 @@ SYMBOL: delayed
|
|||
] with-compilation-unit ;
|
||||
|
||||
: compiled-parse ( state word -- result )
|
||||
swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline
|
||||
swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
|
||||
|
||||
: (parse) ( input parser -- result )
|
||||
dup word? [ compile ] unless compiled-parse ;
|
||||
|
|
@ -527,7 +527,7 @@ M: box-parser (compile) ( peg -- quot )
|
|||
#! to produce the parser to be compiled.
|
||||
#! This differs from 'delay' which calls
|
||||
#! it at run time.
|
||||
quot>> call compile-parser 1quotation ;
|
||||
quot>> call( -- parser ) compile-parser 1quotation ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -17,3 +17,5 @@ IN: peg.search.tests
|
|||
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
|
||||
] unit-test
|
||||
|
||||
\ search must-infer
|
||||
\ replace must-infer
|
||||
|
|
|
|||
|
|
@ -5,16 +5,32 @@ IN: regexp.combinators
|
|||
|
||||
ABOUT: "regexp.combinators"
|
||||
|
||||
ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale"
|
||||
"Regular expression combinators are useful when part of the regular expression contains user input. For example, given a sequence of strings on the stack, a regular expression which matches any one of them can be constructed:"
|
||||
{ $code
|
||||
"[ <literal> ] map <or>"
|
||||
}
|
||||
"Without combinators, a naive approach would look as follows:"
|
||||
{ $code
|
||||
"\"|\" join <regexp>"
|
||||
}
|
||||
"However, this code is incorrect, because one of the strings in the sequence might contain characters which have special meaning inside a regular expression. Combinators avoid this problem by building a regular expression syntax tree directly, without any parsing." ;
|
||||
|
||||
ARTICLE: "regexp.combinators" "Regular expression combinators"
|
||||
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
|
||||
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
|
||||
{ $subsection "regexp.combinators.intro" }
|
||||
"Basic combinators:"
|
||||
{ $subsection <literal> }
|
||||
{ $subsection <nothing> }
|
||||
"Higher-order combinators for building new regular expressions from existing ones:"
|
||||
{ $subsection <or> }
|
||||
{ $subsection <and> }
|
||||
{ $subsection <not> }
|
||||
{ $subsection <sequence> }
|
||||
{ $subsection <zero-or-more> }
|
||||
"Derived combinators implemented in terms of the above:"
|
||||
{ $subsection <one-or-more> }
|
||||
"Setting options:"
|
||||
{ $subsection <option> } ;
|
||||
|
||||
HELP: <literal>
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: regexp.classes kernel sequences regexp.negation
|
||||
quotations assocs fry math locals combinators
|
||||
accessors words compiler.units kernel.private strings
|
||||
sequences.private arrays call namespaces unicode.breaks
|
||||
sequences.private arrays namespaces unicode.breaks
|
||||
regexp.transition-tables combinators.short-circuit ;
|
||||
IN: regexp.compiler
|
||||
|
||||
|
|
@ -104,15 +104,13 @@ C: <box> box
|
|||
transitions>quot ;
|
||||
|
||||
: states>code ( words dfa -- )
|
||||
[ ! with-compilation-unit doesn't compile, so we need call( -- )
|
||||
[
|
||||
'[
|
||||
dup _ word>quot
|
||||
(( last-match index string -- ? ))
|
||||
define-declared
|
||||
] each
|
||||
] with-compilation-unit
|
||||
] call( words dfa -- ) ;
|
||||
[
|
||||
'[
|
||||
dup _ word>quot
|
||||
(( last-match index string -- ? ))
|
||||
define-declared
|
||||
] each
|
||||
] with-compilation-unit ;
|
||||
|
||||
: states>words ( dfa -- words dfa )
|
||||
dup transitions>> keys [ gensym ] H{ } map>assoc
|
||||
|
|
@ -126,7 +124,7 @@ C: <box> box
|
|||
PRIVATE>
|
||||
|
||||
: simple-define-temp ( quot effect -- word )
|
||||
[ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
|
||||
[ define-temp ] with-compilation-unit ;
|
||||
|
||||
: dfa>word ( dfa -- quot )
|
||||
dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs grouping kernel
|
||||
locals math namespaces sequences fry quotations
|
||||
math.order math.ranges vectors unicode.categories
|
||||
regexp.transition-tables words sets hashtables combinators.short-circuit
|
||||
unicode.case.private regexp.ast regexp.classes ;
|
||||
USING: accessors arrays assocs grouping kernel locals math namespaces
|
||||
sequences fry quotations math.order math.ranges vectors
|
||||
unicode.categories regexp.transition-tables words sets hashtables
|
||||
combinators.short-circuit unicode.case unicode.case.private regexp.ast
|
||||
regexp.classes ;
|
||||
IN: regexp.nfa
|
||||
|
||||
! This uses unicode.case.private for ch>upper and ch>lower
|
||||
|
|
|
|||
|
|
@ -1,34 +1,70 @@
|
|||
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings help.markup help.syntax math ;
|
||||
USING: kernel strings help.markup help.syntax math regexp.parser regexp.ast ;
|
||||
IN: regexp
|
||||
|
||||
ABOUT: "regexp"
|
||||
|
||||
ARTICLE: "regexp" "Regular expressions"
|
||||
"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
|
||||
{ $subsection { "regexp" "syntax" } }
|
||||
{ $subsection { "regexp" "construction" } }
|
||||
{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
|
||||
{ $subsection { "regexp" "operations" } }
|
||||
{ $subsection { "regexp" "intro" } }
|
||||
"The class of regular expressions:"
|
||||
{ $subsection regexp }
|
||||
{ $subsection { "regexp" "theory" } } ;
|
||||
"Basic usage:"
|
||||
{ $subsection { "regexp" "syntax" } }
|
||||
{ $subsection { "regexp" "options" } }
|
||||
{ $subsection { "regexp" "construction" } }
|
||||
{ $subsection { "regexp" "operations" } }
|
||||
"Advanced topics:"
|
||||
{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
|
||||
{ $subsection { "regexp" "theory" } }
|
||||
{ $subsection { "regexp" "deploy" } } ;
|
||||
|
||||
ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
|
||||
|
||||
;
|
||||
|
||||
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
|
||||
"Words which are useful for creating regular expressions:"
|
||||
"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
|
||||
{ $subsection POSTPONE: R/ }
|
||||
"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
|
||||
{ $subsection <regexp> }
|
||||
{ $subsection <optioned-regexp> }
|
||||
{ $heading "See also" }
|
||||
{ $vocab-link "regexp.combinators" } ;
|
||||
"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
|
||||
|
||||
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
|
||||
"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl
|
||||
"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
|
||||
"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely. A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "."
|
||||
{ $heading "Characters" }
|
||||
{ $heading "Character classes" }
|
||||
{ $heading "Predefined character classes" }
|
||||
{ $heading "Boundaries" }
|
||||
{ $heading "Greedy quantifiers" }
|
||||
{ $heading "Reluctant quantifiers" }
|
||||
{ $heading "Posessive quantifiers" }
|
||||
{ $heading "Logical operations" }
|
||||
{ $heading "Lookaround" }
|
||||
{ $heading "Unsupported features" }
|
||||
"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
|
||||
"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
|
||||
"Another feature is Perl's " { $snippet "\\G" } " syntax, which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
|
||||
"Additionally, none of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included, for simplicity." ; ! Also describe syntax, from the beginning
|
||||
|
||||
ARTICLE: { "regexp" "options" } "Regular expression options"
|
||||
"When " { $link { "regexp" "construction" } } ", various options can be provided. Options have single-character names. A string of options has one of the following two forms:"
|
||||
{ $code "on" "on-off" }
|
||||
"The latter syntax allows some options to be disabled. The " { $snippet "on" } " and " { $snippet "off" } " strings name options to be enabled and disabled, respectively."
|
||||
$nl
|
||||
"The following options are supported:"
|
||||
{ $table
|
||||
{ "i" { $link case-insensitive } }
|
||||
{ "d" { $link unix-lines } }
|
||||
{ "m" { $link multiline } }
|
||||
{ "n" { $link multiline } }
|
||||
{ "r" { $link reversed-regexp } }
|
||||
{ "s" { $link dotall } }
|
||||
{ "u" { $link unicode-case } }
|
||||
{ "x" { $link comments } }
|
||||
} ;
|
||||
|
||||
ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
|
||||
"Far from being just a practical tool invented by Unix hackers, regular expressions were studied formally before computer programs were written to process them." $nl
|
||||
"A regular language is a set of strings that is matched by a regular expression, which is defined to have characters and the empty string, along with the operations concatenation, disjunction and Kleene star. Another way to define the class of regular languages is as the class of languages which can be recognized with constant space overhead, ie with a DFA. These two definitions are provably equivalent." $nl
|
||||
|
|
@ -39,26 +75,41 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
|
|||
"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
|
||||
|
||||
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
|
||||
"Testing if a string matches a regular expression:"
|
||||
{ $subsection matches? }
|
||||
"Finding a match inside a string:"
|
||||
{ $subsection re-contains? }
|
||||
{ $subsection first-match }
|
||||
"Finding all matches inside a string:"
|
||||
{ $subsection count-matches }
|
||||
{ $subsection all-matching-slices }
|
||||
{ $subsection all-matching-subseqs }
|
||||
"Splitting a string into tokens delimited by a regular expression:"
|
||||
{ $subsection re-split }
|
||||
{ $subsection re-replace }
|
||||
{ $subsection count-matches } ;
|
||||
"Replacing occurrences of a regular expression with a string:"
|
||||
{ $subsection re-replace } ;
|
||||
|
||||
ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
|
||||
"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
|
||||
$nl
|
||||
"Regular expressions constructed at runtime from a deployed application will be compiled with the non-optimizing compiler, which is always available because it is built into the Factor VM. This will result in lower performance than when using the optimizing compiler."
|
||||
$nl
|
||||
"Literal regular expressions constructed at parse time do not suffer from this restriction, since the deployed application is loaded and compiled before anything is stripped out."
|
||||
$nl
|
||||
"None of this applies to deployed applications which include the optimizing compiler, or code running inside a development image."
|
||||
{ $see-also "compiler" { "regexp" "construction" } "deploy-flags" } ;
|
||||
|
||||
HELP: <regexp>
|
||||
{ $values { "string" string } { "regexp" regexp } }
|
||||
{ $description "Creates a regular expression object, given a string in regular expression syntax. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
|
||||
|
||||
HELP: <optioned-regexp>
|
||||
{ $values { "string" string } { "options" string } { "regexp" regexp } }
|
||||
{ $values { "string" string } { "options" "a string of " { $link { "regexp" "options" } } } { "regexp" regexp } }
|
||||
{ $description "Given a string in regular expression syntax, and a string of options, creates a regular expression object. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
|
||||
|
||||
HELP: R/
|
||||
{ $syntax "R/ foo.*|[a-zA-Z]bar/i" }
|
||||
{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
|
||||
{ $syntax "R/ foo.*|[a-zA-Z]bar/options" }
|
||||
{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use. The syntax for the " { $snippet "options" } " string is documented in " { $link { "regexp" "options" } } "." } ;
|
||||
|
||||
HELP: regexp
|
||||
{ $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
|
||||
|
|
|
|||
|
|
@ -73,6 +73,20 @@ HELP: send-email
|
|||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "smtp-gmail" "Setting up SMTP with gmail"
|
||||
"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link "factor-boot-rc" } "." $nl
|
||||
"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
|
||||
{ $code
|
||||
"USING: smtp namespaces io.sockets ;"
|
||||
""
|
||||
"\"my.gmail.address@gmail.com\" \"secret-password\" <plain-auth> smtp-auth set-global"
|
||||
""
|
||||
"\"smtp.gmail.com\" 587 <inet> smtp-server set-global"
|
||||
""
|
||||
"t smtp-tls? set-global"
|
||||
} ;
|
||||
|
||||
|
||||
ARTICLE: "smtp" "SMTP client library"
|
||||
"The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
|
||||
$nl
|
||||
|
|
@ -89,6 +103,8 @@ $nl
|
|||
{ $subsection email }
|
||||
{ $subsection <email> }
|
||||
"Sending an email:"
|
||||
{ $subsection send-email } ;
|
||||
{ $subsection send-email }
|
||||
"More topics:"
|
||||
{ $subsection "smtp-gmail" } ;
|
||||
|
||||
ABOUT: "smtp"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax words alien.c-types assocs
|
||||
kernel ;
|
||||
kernel call call.private tools.deploy.config ;
|
||||
IN: tools.deploy
|
||||
|
||||
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
||||
|
|
@ -7,25 +7,43 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
|||
{ $subsection "deploy-config" }
|
||||
{ $subsection "deploy-flags" } ;
|
||||
|
||||
ARTICLE: "tools.deploy" "Application deployment"
|
||||
"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
|
||||
$nl
|
||||
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
|
||||
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
|
||||
"Once the necessary deployment flags have been set, the application can be deployed:"
|
||||
{ $subsection deploy }
|
||||
"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
|
||||
{ $code "\"hello-ui\" deploy" }
|
||||
{ $list
|
||||
{ "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
|
||||
{ "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
|
||||
{ "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
|
||||
}
|
||||
"In all cases, running the program displays a window with a message."
|
||||
$nl
|
||||
"On all platforms, running the program will display a window with a message." ;
|
||||
|
||||
ARTICLE: "tools.deploy.impl" "Deploy tool implementation"
|
||||
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
|
||||
$nl
|
||||
"The deploy tool generates " { $emphasis "staging images" } " containing major subsystems, and uses the staging images to derive the final application image. The first time an application is deployed using a major subsystem, such as the UI, a new staging image is made, which can take a few minutes. Subsequent deployments of applications using this subsystem will be much faster." ;
|
||||
|
||||
ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
|
||||
{ $heading "Behavior of " { $link boa } }
|
||||
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
|
||||
{ $heading "Behavior of " { $link POSTPONE: execute( } }
|
||||
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "."
|
||||
{ $heading "Error reporting" }
|
||||
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
|
||||
{ $heading "Choosing the right deploy flags" }
|
||||
"Finding the correct deploy flags is a trial and error process; you must find a tradeoff between deployed image size and correctness. If your program uses dynamic language features, you may need to elect to strip out fewer subsystems in order to have full functionality." ;
|
||||
|
||||
ARTICLE: "tools.deploy" "Application deployment"
|
||||
"The stand-alone application deployment tool, implemented in the " { $vocab-link "tools.deploy" } " vocablary, compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
|
||||
$nl
|
||||
"Most of the time, the words in the " { $vocab-link "tools.deploy" } " vocabulary should not be used directly; instead, use " { $link "ui.tools.deploy" } "."
|
||||
$nl
|
||||
"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
|
||||
{ $subsection "prepare-deploy" }
|
||||
"Once the necessary deployment flags have been set, the application can be deployed:"
|
||||
{ $subsection deploy }
|
||||
{ $see-also "ui.tools.deploy" } ;
|
||||
{ $subsection "tools.deploy.usage" }
|
||||
{ $subsection "tools.deploy.impl" }
|
||||
{ $subsection "tools.deploy.caveats" } ;
|
||||
|
||||
ABOUT: "tools.deploy"
|
||||
|
||||
|
|
|
|||
|
|
@ -80,32 +80,17 @@ M: quit-responder call-responder*
|
|||
|
||||
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.6" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.7" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.9" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.10" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.11" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
{
|
||||
"tools.deploy.test.6"
|
||||
"tools.deploy.test.7"
|
||||
"tools.deploy.test.8"
|
||||
"tools.deploy.test.9"
|
||||
"tools.deploy.test.10"
|
||||
"tools.deploy.test.11"
|
||||
"tools.deploy.test.12"
|
||||
} [
|
||||
[ ] swap [
|
||||
shake-and-bake
|
||||
run-temp-image
|
||||
] curry unit-test
|
||||
] each
|
||||
|
|
@ -53,6 +53,13 @@ IN: tools.deploy.shaker
|
|||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-call ( -- )
|
||||
"call" vocab [
|
||||
"Stripping stack effect checking from call( and execute(" show
|
||||
"vocab:tools/deploy/shaker/strip-call.factor"
|
||||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
"cocoa" vocab [
|
||||
"Stripping unused Cocoa methods" show
|
||||
|
|
@ -256,9 +263,7 @@ IN: tools.deploy.shaker
|
|||
command-line:main-vocab-hook
|
||||
compiled-crossref
|
||||
compiled-generic-crossref
|
||||
recompile-hook
|
||||
update-tuples-hook
|
||||
remake-generics-hook
|
||||
compiler-impl
|
||||
definition-observers
|
||||
definitions:crossref
|
||||
interactive-vocabs
|
||||
|
|
@ -399,6 +404,7 @@ SYMBOL: deploy-vocab
|
|||
init-stripper
|
||||
strip-default-methods
|
||||
strip-libc
|
||||
strip-call
|
||||
strip-cocoa
|
||||
strip-debugger
|
||||
compute-next-methods
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: tools.deploy.shaker.call
|
||||
|
||||
IN: call
|
||||
USE: call.private
|
||||
|
||||
: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: call math.parser io math ;
|
||||
IN: tools.deploy.test.12
|
||||
|
||||
: execute-test ( a b w -- c ) execute( a b -- c ) ;
|
||||
|
||||
: foo ( -- ) 1 2 \ + execute-test number>string print ;
|
||||
|
||||
MAIN: foo
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-math? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-name "tools.deploy.test.12" }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-threads? f }
|
||||
}
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: regexp kernel io ;
|
||||
IN: tools.deploy.test.13
|
||||
|
||||
: regexp-test ( a -- b ) <regexp> "xyz" swap matches? ;
|
||||
|
||||
: main ( -- ) "x.z" regexp-test "X" "Y" ? print ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-threads? t }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-io 2 }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-name "tools.deploy.test.13" }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-reflection 4 }
|
||||
{ deploy-ui? f }
|
||||
}
|
||||
|
|
@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
|
|||
vocabs.loader io combinators calendar accessors math.parser
|
||||
io.streams.string ui.tools.operations quotations strings arrays
|
||||
prettyprint words vocabs sorting sets classes math alien urls
|
||||
splitting ascii combinators.short-circuit ;
|
||||
splitting ascii combinators.short-circuit alarms words.symbol ;
|
||||
IN: tools.scaffold
|
||||
|
||||
SYMBOL: developer-name
|
||||
|
|
@ -116,6 +116,7 @@ ERROR: no-vocab vocab ;
|
|||
{ "ch" "a character" }
|
||||
{ "word" word }
|
||||
{ "array" array }
|
||||
{ "alarm" alarm }
|
||||
{ "duration" duration }
|
||||
{ "path" "a pathname string" }
|
||||
{ "vocab" "a vocabulary specifier" }
|
||||
|
|
@ -134,7 +135,7 @@ ERROR: no-vocab vocab ;
|
|||
|
||||
: ($values.) ( array -- )
|
||||
[
|
||||
" { " write
|
||||
"{ " write
|
||||
dup array? [ first ] when
|
||||
dup lookup-type [
|
||||
[ unparse write bl ]
|
||||
|
|
@ -162,15 +163,26 @@ ERROR: no-vocab vocab ;
|
|||
] if
|
||||
] when* ;
|
||||
|
||||
: symbol-description. ( word -- )
|
||||
drop
|
||||
"{ $var-description \"\" } ;" print ;
|
||||
|
||||
: $description. ( word -- )
|
||||
drop
|
||||
"{ $description \"\" } ;" print ;
|
||||
|
||||
: docs-body. ( word/symbol -- )
|
||||
dup symbol? [
|
||||
symbol-description.
|
||||
] [
|
||||
[ $values. ] [ $description. ] bi
|
||||
] if ;
|
||||
|
||||
: docs-header. ( word -- )
|
||||
"HELP: " write name>> print ;
|
||||
|
||||
: (help.) ( word -- )
|
||||
[ docs-header. ] [ $values. ] [ $description. ] tri ;
|
||||
[ docs-header. ] [ docs-body. ] bi ;
|
||||
|
||||
: interesting-words ( vocab -- array )
|
||||
words
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences namespaces ui.gadgets.frames
|
||||
ui.pens.image ui.gadgets.icons ui.gadgets.grids ;
|
||||
IN: ui.gadgets.corners
|
||||
|
||||
CONSTANT: @center { 1 1 }
|
||||
CONSTANT: @left { 0 1 }
|
||||
CONSTANT: @right { 2 1 }
|
||||
CONSTANT: @top { 1 0 }
|
||||
CONSTANT: @bottom { 1 2 }
|
||||
|
||||
CONSTANT: @top-left { 0 0 }
|
||||
CONSTANT: @top-right { 2 0 }
|
||||
CONSTANT: @bottom-left { 0 2 }
|
||||
CONSTANT: @bottom-right { 2 2 }
|
||||
|
||||
SYMBOL: name
|
||||
|
||||
: corner-image ( name -- image )
|
||||
[ name get "-" ] dip 3append theme-image ;
|
||||
|
||||
: corner-icon ( name -- icon )
|
||||
corner-image <icon> ;
|
||||
|
||||
: /-----\ ( corner -- corner )
|
||||
"top-left" corner-icon @top-left grid-add
|
||||
"top-middle" corner-icon @top grid-add
|
||||
"top-right" corner-icon @top-right grid-add ;
|
||||
|
||||
: |-----| ( gadget corner -- corner )
|
||||
"left-edge" corner-icon @left grid-add
|
||||
swap @center grid-add
|
||||
"right-edge" corner-icon @right grid-add ;
|
||||
|
||||
: \-----/ ( corner -- corner )
|
||||
"bottom-left" corner-icon @bottom-left grid-add
|
||||
"bottom-middle" corner-icon @bottom grid-add
|
||||
"bottom-right" corner-icon @bottom-right grid-add ;
|
||||
|
||||
: make-corners ( class name quot -- corners )
|
||||
[ [ [ 3 3 ] dip new-frame { 1 1 } >>filled-cell ] dip name ] dip
|
||||
with-variable ; inline
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: ui.gadgets.labeled.tests
|
||||
USING: ui.gadgets ui.gadgets.labeled accessors tools.test ;
|
||||
|
||||
[ t ] [ <gadget> "Hey" <labeled-gadget> content>> gadget? ] unit-test
|
||||
|
|
@ -2,67 +2,33 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences colors fonts ui.gadgets
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.icons ui.gadgets.labels
|
||||
ui.gadgets.borders ui.pens.image ;
|
||||
ui.gadgets.borders ui.pens.image ui.gadgets.corners ui.render ;
|
||||
IN: ui.gadgets.labeled
|
||||
|
||||
TUPLE: labeled-gadget < frame content ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: @center { 1 1 }
|
||||
CONSTANT: @left { 0 1 }
|
||||
CONSTANT: @right { 2 1 }
|
||||
CONSTANT: @top { 1 0 }
|
||||
CONSTANT: @bottom { 1 2 }
|
||||
|
||||
CONSTANT: @top-left { 0 0 }
|
||||
CONSTANT: @top-right { 2 0 }
|
||||
CONSTANT: @bottom-left { 0 2 }
|
||||
CONSTANT: @bottom-right { 2 2 }
|
||||
|
||||
: labeled-image ( name -- image )
|
||||
"labeled-block-" prepend theme-image ;
|
||||
|
||||
: labeled-icon ( name -- icon )
|
||||
labeled-image <icon> ;
|
||||
|
||||
CONSTANT: labeled-title-background
|
||||
T{ rgba f
|
||||
0.7843137254901961
|
||||
0.7686274509803922
|
||||
0.7176470588235294
|
||||
1.0
|
||||
}
|
||||
|
||||
: <labeled-title> ( gadget -- label )
|
||||
>label
|
||||
[ labeled-title-background font-with-background ] change-font
|
||||
[ panel-background-color font-with-background ] change-font
|
||||
{ 0 2 } <border>
|
||||
"title-middle" labeled-image
|
||||
"title-middle" corner-image
|
||||
<image-pen> t >>fill? >>interior ;
|
||||
|
||||
: /-FOO-\ ( title labeled -- labeled )
|
||||
"title-left" labeled-icon @top-left grid-add
|
||||
"title-left" corner-icon @top-left grid-add
|
||||
swap <labeled-title> @top grid-add
|
||||
"title-right" labeled-icon @top-right grid-add ;
|
||||
|
||||
: |-----| ( gadget labeled -- labeled )
|
||||
"left-edge" labeled-icon @left grid-add
|
||||
swap [ >>content ] [ @center grid-add ] bi
|
||||
"right-edge" labeled-icon @right grid-add ;
|
||||
|
||||
: \-----/ ( labeled -- labeled )
|
||||
"bottom-left" labeled-icon @bottom-left grid-add
|
||||
"bottom-middle" labeled-icon @bottom grid-add
|
||||
"bottom-right" labeled-icon @bottom-right grid-add ;
|
||||
"title-right" corner-icon @top-right grid-add ;
|
||||
|
||||
M: labeled-gadget focusable-child* content>> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <labeled-gadget> ( gadget title -- newgadget )
|
||||
3 3 labeled-gadget new-frame
|
||||
{ 1 1 } >>filled-cell
|
||||
labeled-gadget "labeled-block" [
|
||||
pick >>content
|
||||
/-FOO-\
|
||||
|-----|
|
||||
\-----/ ;
|
||||
\-----/
|
||||
] make-corners ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: colors.constants kernel locals math.rectangles
|
||||
namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
|
||||
ui.gadgets.worlds ui.gestures ui.operations ui.pens ui.pens.solid
|
||||
opengl math.vectors words accessors math math.order sorting ;
|
||||
USING: colors.constants kernel locals math.rectangles namespaces
|
||||
sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
|
||||
ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations
|
||||
ui.render ui.pens ui.pens.solid opengl math.vectors words accessors
|
||||
math math.order sorting ;
|
||||
IN: ui.gadgets.menus
|
||||
|
||||
: show-menu ( owner menu -- )
|
||||
|
|
@ -30,6 +31,10 @@ M: separator-pen draw-interior
|
|||
dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
|
||||
[ [ >integer ] map ] bi@ gl-line ;
|
||||
|
||||
: <menu-items> ( items -- gadget )
|
||||
[ <filled-pile> ] dip add-gadgets
|
||||
panel-background-color <solid> >>interior ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: ----
|
||||
|
|
@ -43,10 +48,16 @@ M: ---- <menu-item>
|
|||
: menu-theme ( gadget -- gadget )
|
||||
COLOR: light-gray <solid> >>interior ;
|
||||
|
||||
: <menu> ( gadgets -- menu )
|
||||
<menu-items>
|
||||
frame "menu-background" [
|
||||
/-----\
|
||||
|-----|
|
||||
\-----/
|
||||
] make-corners ;
|
||||
|
||||
: <commands-menu> ( target hook commands -- menu )
|
||||
[ <filled-pile> ] 3dip
|
||||
[ <menu-item> add-gadget ] with with each
|
||||
{ 5 5 } <border> menu-theme ;
|
||||
[ <menu-item> ] with with map <menu> ;
|
||||
|
||||
: show-commands-menu ( target commands -- )
|
||||
[ dup [ ] ] dip <commands-menu> show-menu ;
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ TUPLE: pane-stream pane ;
|
|||
|
||||
C: <pane-stream> pane-stream
|
||||
|
||||
M: pane-stream stream-element-type drop +character+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: clear-selection ( pane -- pane )
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -112,4 +112,12 @@ M: gadget draw-children
|
|||
|
||||
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
|
||||
|
||||
CONSTANT: panel-background-color
|
||||
T{ rgba f
|
||||
0.7843137254901961
|
||||
0.7686274509803922
|
||||
0.7176470588235294
|
||||
1.0
|
||||
}
|
||||
|
||||
CONSTANT: focus-border-color COLOR: dark-gray
|
||||
|
|
|
|||
|
|
@ -84,6 +84,8 @@ M: interactor model-changed
|
|||
[ 2drop ] [ [ value>> ] dip show-summary ] if
|
||||
] [ call-next-method ] if ;
|
||||
|
||||
M: interactor stream-element-type drop +character+ ;
|
||||
|
||||
GENERIC: (print-input) ( object -- )
|
||||
|
||||
M: input (print-input)
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ H{ } clone sub-primitives set
|
|||
dictionary
|
||||
new-classes
|
||||
changed-definitions changed-generics
|
||||
remake-generics forgotten-definitions
|
||||
outdated-generics forgotten-definitions
|
||||
root-cache source-files update-map implementors-map
|
||||
} [ H{ } clone swap set ] each
|
||||
|
||||
|
|
@ -47,7 +47,9 @@ init-caches
|
|||
|
||||
! Trivial recompile hook. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
[ drop { } ] recompile-hook set
|
||||
SINGLETON: dummy-compiler
|
||||
M: dummy-compiler recompile drop { } ;
|
||||
dummy-compiler compiler-impl set
|
||||
|
||||
call
|
||||
call
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math
|
|||
namespaces make sequences sequences.private strings vectors
|
||||
words quotations memory combinators generic classes
|
||||
classes.algebra classes.builtin classes.private slots.private
|
||||
slots compiler.units math.private accessors assocs effects ;
|
||||
slots math.private accessors assocs effects ;
|
||||
IN: classes.tuple
|
||||
|
||||
PREDICATE: tuple-class < class
|
||||
|
|
@ -188,6 +188,8 @@ ERROR: bad-superclass class ;
|
|||
: apply-slot-permutation ( old-values triples -- new-values )
|
||||
[ first3 update-slot ] with map ;
|
||||
|
||||
SYMBOL: outdated-tuples
|
||||
|
||||
: permute-slots ( old-values layout -- new-values )
|
||||
[ first all-slots ] [ outdated-tuples get at ] bi
|
||||
compute-slot-permutation
|
||||
|
|
@ -212,8 +214,6 @@ ERROR: bad-superclass class ;
|
|||
dup [ update-tuple ] map become
|
||||
] if ;
|
||||
|
||||
[ update-tuples ] update-tuples-hook set-global
|
||||
|
||||
: update-tuples-after ( class -- )
|
||||
[ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ $nl
|
|||
"Forward reference checking (see " { $link "definition-checking" } "):"
|
||||
{ $subsection forward-reference? }
|
||||
"A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":"
|
||||
{ $subsection recompile-hook }
|
||||
{ $subsection recompile }
|
||||
"Low-level compiler interface exported by the Factor VM:"
|
||||
{ $subsection modify-code-heap } ;
|
||||
|
||||
|
|
@ -47,8 +47,9 @@ $nl
|
|||
$nl
|
||||
"Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
|
||||
|
||||
HELP: recompile-hook
|
||||
{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
|
||||
HELP: recompile
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to compiled definitions" } }
|
||||
{ $contract "Internal word which compiles words. Called at the end of " { $link with-compilation-unit } "." } ;
|
||||
|
||||
HELP: no-compilation-unit
|
||||
{ $values { "word" word } }
|
||||
|
|
|
|||
|
|
@ -2,6 +2,9 @@ IN: compiler.units.tests
|
|||
USING: definitions compiler.units tools.test arrays sequences words kernel
|
||||
accessors namespaces fry ;
|
||||
|
||||
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
|
||||
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
|
||||
|
||||
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
|
||||
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
|
||||
[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel continuations assocs namespaces
|
||||
sequences words vocabs definitions hashtables init sets
|
||||
math math.order classes classes.algebra ;
|
||||
math math.order classes classes.algebra classes.tuple
|
||||
classes.tuple.private generic ;
|
||||
IN: compiler.units
|
||||
|
||||
SYMBOL: old-definitions
|
||||
|
|
@ -35,7 +36,11 @@ TUPLE: redefine-error def ;
|
|||
[ new-definitions get assoc-stack not ]
|
||||
[ drop f ] if ;
|
||||
|
||||
SYMBOL: recompile-hook
|
||||
SYMBOL: compiler-impl
|
||||
|
||||
HOOK: recompile compiler-impl ( words -- alist )
|
||||
|
||||
M: f recompile [ f ] { } map>assoc ;
|
||||
|
||||
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
|
||||
|
||||
|
|
@ -68,12 +73,7 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
dup changed-definitions get update
|
||||
dup dup changed-vocabs update ;
|
||||
|
||||
: compile ( words -- )
|
||||
recompile-hook get call modify-code-heap ;
|
||||
|
||||
SYMBOL: outdated-tuples
|
||||
SYMBOL: update-tuples-hook
|
||||
SYMBOL: remake-generics-hook
|
||||
: compile ( words -- ) recompile modify-code-heap ;
|
||||
|
||||
: index>= ( obj1 obj2 seq -- ? )
|
||||
[ index ] curry bi@ >= ;
|
||||
|
|
@ -125,24 +125,15 @@ SYMBOL: remake-generics-hook
|
|||
changed-generics get compiled-generic-usages
|
||||
append assoc-combine keys ;
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
to-recompile recompile-hook get call ;
|
||||
|
||||
: call-remake-generics-hook ( -- )
|
||||
remake-generics-hook get call ;
|
||||
|
||||
: call-update-tuples-hook ( -- )
|
||||
update-tuples-hook get call ;
|
||||
|
||||
: unxref-forgotten-definitions ( -- )
|
||||
forgotten-definitions get
|
||||
keys [ word? ] filter
|
||||
[ delete-compiled-xref ] each ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
call-remake-generics-hook
|
||||
call-recompile-hook
|
||||
call-update-tuples-hook
|
||||
remake-generics
|
||||
to-recompile recompile
|
||||
update-tuples
|
||||
unxref-forgotten-definitions
|
||||
modify-code-heap ;
|
||||
|
||||
|
|
@ -150,7 +141,7 @@ SYMBOL: remake-generics-hook
|
|||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone remake-generics set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-classes set
|
||||
[ finish-compilation-unit ] [ ] cleanup
|
||||
|
|
@ -160,7 +151,7 @@ SYMBOL: remake-generics-hook
|
|||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone remake-generics set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone forgotten-definitions set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-classes set
|
||||
|
|
@ -172,8 +163,3 @@ SYMBOL: remake-generics-hook
|
|||
notify-definition-observers
|
||||
] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: default-recompile-hook ( words -- alist )
|
||||
[ f ] { } map>assoc ;
|
||||
|
||||
recompile-hook [ [ default-recompile-hook ] ] initialize
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: changed-definitions
|
|||
|
||||
SYMBOL: changed-generics
|
||||
|
||||
SYMBOL: remake-generics
|
||||
SYMBOL: outdated-generics
|
||||
|
||||
SYMBOL: new-classes
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors words kernel sequences namespaces make assocs
|
||||
hashtables definitions kernel.private classes classes.private
|
||||
classes.algebra quotations arrays vocabs effects combinators
|
||||
sets compiler.units ;
|
||||
sets ;
|
||||
IN: generic
|
||||
|
||||
! Method combination protocol
|
||||
|
|
@ -21,11 +21,6 @@ M: generic definition drop f ;
|
|||
[ dup "combination" word-prop perform-combination ]
|
||||
bi ;
|
||||
|
||||
[
|
||||
remake-generics get keys
|
||||
[ generic? ] filter [ make-generic ] each
|
||||
] remake-generics-hook set-global
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
|
|
@ -76,7 +71,10 @@ TUPLE: check-method class generic ;
|
|||
[ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
|
||||
|
||||
: remake-generic ( generic -- )
|
||||
dup remake-generics get set-in-unit ;
|
||||
dup outdated-generics get set-in-unit ;
|
||||
|
||||
: remake-generics ( -- )
|
||||
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
|
||||
|
||||
: with-methods ( class generic quot -- )
|
||||
[ drop changed-generic ]
|
||||
|
|
|
|||
|
|
@ -47,6 +47,9 @@ M: object <decoder> f decoder boa ;
|
|||
] when
|
||||
] when nip ; inline
|
||||
|
||||
M: decoder stream-element-type
|
||||
drop +character+ ;
|
||||
|
||||
M: decoder stream-read1
|
||||
dup >decoder< decode-char fix-read1 ;
|
||||
|
||||
|
|
@ -121,6 +124,9 @@ M: object <encoder> encoder boa ;
|
|||
: >encoder< ( encoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ; inline
|
||||
|
||||
M: encoder stream-element-type
|
||||
drop +character+ ;
|
||||
|
||||
M: encoder stream-write1
|
||||
>encoder< encode-char ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,24 @@ USING: help.markup help.syntax quotations hashtables kernel
|
|||
classes strings continuations destructors math byte-arrays ;
|
||||
IN: io
|
||||
|
||||
HELP: +byte+
|
||||
{ $description "A stream element type. See " { $link stream-element-type } " for explanation." } ;
|
||||
|
||||
HELP: +character+
|
||||
{ $description "A stream element type. See " { $link stream-element-type } " for explanation." } ;
|
||||
|
||||
HELP: stream-element-type
|
||||
{ $values { "stream" "a stream" } { "type" { $link +byte+ } " or " { $link +character+ } } }
|
||||
{ $description
|
||||
"Outputs one of the following two values:"
|
||||
{ $list
|
||||
{ { $link +byte+ } " - indicates that stream elements are integers in the range " { $snippet "[0,255]" } "; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." }
|
||||
{ { $link +character+ } " - indicates that stream elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." }
|
||||
}
|
||||
"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "."
|
||||
|
||||
} ;
|
||||
|
||||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
|
||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
|
|
@ -68,7 +86,6 @@ HELP: stream-copy
|
|||
{ $description "Copies the contents of one stream into another, closing both streams when done." }
|
||||
$io-error ;
|
||||
|
||||
|
||||
HELP: stream-seek
|
||||
{ $values
|
||||
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
|
||||
|
|
@ -228,6 +245,8 @@ $nl
|
|||
$nl
|
||||
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
|
||||
$nl
|
||||
"The following word is required for all input and output streams:"
|
||||
{ $subsection stream-element-type }
|
||||
"These words are required for binary and string input streams:"
|
||||
{ $subsection stream-read1 }
|
||||
{ $subsection stream-read }
|
||||
|
|
@ -337,17 +356,9 @@ $nl
|
|||
"Copying the contents of one stream to another:"
|
||||
{ $subsection stream-copy } ;
|
||||
|
||||
ARTICLE: "stream-elements" "Stream elements"
|
||||
"There are two types of streams:"
|
||||
{ $list
|
||||
{ { $strong "Binary streams" } " - the elements are integers between 0 and 255, inclusive; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." }
|
||||
{ { $strong "String streams" } " - the elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." }
|
||||
}
|
||||
"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "." ;
|
||||
|
||||
ARTICLE: "streams" "Streams"
|
||||
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of elements."
|
||||
{ $subsection "stream-elements" }
|
||||
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "."
|
||||
$nl
|
||||
"A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "."
|
||||
{ $subsection "stream-protocol" }
|
||||
{ $subsection "stdio" }
|
||||
|
|
|
|||
|
|
@ -4,6 +4,10 @@ USING: hashtables generic kernel math namespaces make sequences
|
|||
continuations destructors assocs ;
|
||||
IN: io
|
||||
|
||||
SYMBOLS: +byte+ +character+ ;
|
||||
|
||||
GENERIC: stream-element-type ( stream -- type )
|
||||
|
||||
GENERIC: stream-read1 ( stream -- elt )
|
||||
GENERIC: stream-read ( n stream -- seq )
|
||||
GENERIC: stream-read-until ( seps stream -- seq sep/f )
|
||||
|
|
|
|||
|
|
@ -9,35 +9,27 @@ TUPLE: c-writer handle disposed ;
|
|||
|
||||
: <c-writer> ( handle -- stream ) f c-writer boa ;
|
||||
|
||||
M: c-writer stream-write1
|
||||
dup check-disposed
|
||||
handle>> fputc ;
|
||||
M: c-writer stream-element-type drop +byte+ ;
|
||||
|
||||
M: c-writer stream-write
|
||||
dup check-disposed
|
||||
handle>> fwrite ;
|
||||
M: c-writer stream-write1 dup check-disposed handle>> fputc ;
|
||||
|
||||
M: c-writer stream-flush
|
||||
dup check-disposed
|
||||
handle>> fflush ;
|
||||
M: c-writer stream-write dup check-disposed handle>> fwrite ;
|
||||
|
||||
M: c-writer dispose*
|
||||
handle>> fclose ;
|
||||
M: c-writer stream-flush dup check-disposed handle>> fflush ;
|
||||
|
||||
M: c-writer dispose* handle>> fclose ;
|
||||
|
||||
TUPLE: c-reader handle disposed ;
|
||||
|
||||
: <c-reader> ( handle -- stream ) f c-reader boa ;
|
||||
|
||||
M: c-reader stream-read
|
||||
dup check-disposed
|
||||
handle>> fread ;
|
||||
M: c-reader stream-element-type drop +byte+ ;
|
||||
|
||||
M: c-reader stream-read-partial
|
||||
stream-read ;
|
||||
M: c-reader stream-read dup check-disposed handle>> fread ;
|
||||
|
||||
M: c-reader stream-read1
|
||||
dup check-disposed
|
||||
handle>> fgetc ;
|
||||
M: c-reader stream-read-partial stream-read ;
|
||||
|
||||
M: c-reader stream-read1 dup check-disposed handle>> fgetc ;
|
||||
|
||||
: read-until-loop ( stream delim -- ch )
|
||||
over stream-read1 dup [
|
||||
|
|
|
|||
|
|
@ -9,11 +9,13 @@ INSTANCE: null-writer plain-writer
|
|||
|
||||
M: null-stream dispose drop ;
|
||||
|
||||
M: null-reader stream-element-type drop +byte+ ;
|
||||
M: null-reader stream-readln drop f ;
|
||||
M: null-reader stream-read1 drop f ;
|
||||
M: null-reader stream-read-until 2drop f f ;
|
||||
M: null-reader stream-read 2drop f ;
|
||||
|
||||
M: null-writer stream-element-type drop +byte+ ;
|
||||
M: null-writer stream-write1 2drop ;
|
||||
M: null-writer stream-write 2drop ;
|
||||
M: null-writer stream-flush drop ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences io kernel accessors math math.order ;
|
||||
USING: sequences io io.streams.plain kernel accessors math math.order
|
||||
growable destructors ;
|
||||
IN: io.streams.sequence
|
||||
|
||||
! Readers
|
||||
SLOT: underlying
|
||||
SLOT: i
|
||||
|
||||
|
|
@ -36,3 +38,12 @@ SLOT: i
|
|||
: sequence-read-until ( separators stream -- seq sep/f )
|
||||
[ find-sep ] keep
|
||||
[ sequence-read ] [ next ] bi swap ; inline
|
||||
|
||||
! Writers
|
||||
M: growable dispose drop ;
|
||||
|
||||
M: growable stream-write1 push ;
|
||||
M: growable stream-write push-all ;
|
||||
M: growable stream-flush drop ;
|
||||
|
||||
INSTANCE: growable plain-writer
|
||||
|
|
@ -356,9 +356,9 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
: fjsc-compile* ( string -- string )
|
||||
'statement' parse ast>> fjsc-compile ;
|
||||
|
||||
: fc* ( string -- string )
|
||||
: fc* ( string -- )
|
||||
[
|
||||
'statement' parse ast>> values>> do-expressions
|
||||
'statement' parse ast>> values>> do-expressions
|
||||
] { } make [ write ] each ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: geo-ip
|
|||
|
||||
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
|
||||
|
||||
: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
|
||||
CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download"
|
||||
|
||||
: download-db ( -- path )
|
||||
db-path dup exists? [
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators combinators.smart csv io.encodings.8-bit
|
||||
math.parser memoize sequences kernel unicode.categories money ;
|
||||
IN: geobytes
|
||||
|
||||
! GeoBytes is not free software.
|
||||
! Please read their license should you choose to use it.
|
||||
! This is just a binding to the GeoBytes CSV files.
|
||||
! Download and install GeoBytes yourself should you wish to use it.
|
||||
! http://www.geobytes.com/GeoWorldMap.zip
|
||||
|
||||
CONSTANT: geobytes-cities-path "resource:GeoWorldMap/Cities.txt"
|
||||
CONSTANT: geobytes-countries-path "resource:GeoWorldMap/Countries.txt"
|
||||
CONSTANT: geobytes-regions-path "resource:GeoWorldMap/Regions.txt"
|
||||
CONSTANT: geobytes-version-path "resource:GeoWorldMap/version.txt"
|
||||
|
||||
TUPLE: country country-id country fips104 iso2 iso3 ison internet capital map-reference
|
||||
nationality-singular nationality-plural currency currency-code population title
|
||||
comment ;
|
||||
|
||||
TUPLE: region region-id country-id region code adm1-code ;
|
||||
|
||||
TUPLE: city city-id country-id region-id city longitude latitude timezone code ;
|
||||
|
||||
TUPLE: version component version rows ;
|
||||
|
||||
MEMO: load-countries ( -- seq )
|
||||
geobytes-countries-path latin1 file>csv rest-slice [
|
||||
[
|
||||
{
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ ]
|
||||
} spread country boa
|
||||
] input<sequence
|
||||
] map ;
|
||||
|
||||
MEMO: load-regions ( -- seq )
|
||||
geobytes-regions-path latin1 file>csv rest-slice [
|
||||
[
|
||||
{
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ [ blank? ] trim ]
|
||||
} spread region boa
|
||||
] input<sequence
|
||||
] map ;
|
||||
|
||||
MEMO: load-cities ( -- seq )
|
||||
geobytes-cities-path latin1 file>csv rest-slice [
|
||||
[
|
||||
{
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ parse-decimal ]
|
||||
[ parse-decimal ]
|
||||
[ ]
|
||||
[ string>number ]
|
||||
} spread city boa
|
||||
] input<sequence
|
||||
] map ;
|
||||
|
||||
MEMO: load-version ( -- seq )
|
||||
geobytes-version-path latin1 file>csv rest-slice [
|
||||
[
|
||||
{
|
||||
[ ]
|
||||
[ ]
|
||||
[ string>number ]
|
||||
} spread version boa
|
||||
] input<sequence
|
||||
] map ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
City, country, region database using database from http://www.geobytes.com/GeoWorldMap.zip
|
||||
|
|
@ -0,0 +1 @@
|
|||
enterprise
|
||||
|
|
@ -10,4 +10,5 @@ IN: html.parser.state.tests
|
|||
[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
|
||||
[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
|
||||
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
|
||||
! [ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
|
||||
[ "foo " " bar" ]
|
||||
[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
|
||||
|
|
|
|||
|
|
@ -29,13 +29,13 @@ TUPLE: state string i ;
|
|||
] [ drop ] if ; inline recursive
|
||||
|
||||
: take-until ( quot: ( -- ? ) -- )
|
||||
[ get-i ] dip skip-until get-i
|
||||
get-i [ skip-until ] dip get-i
|
||||
state get string>> subseq ;
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-circular sequence= ;
|
||||
get-char over push-growing-circular sequence= ;
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <circular-string>
|
||||
dup length <growing-circular>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next ;
|
||||
|
|
|
|||
|
|
@ -1,235 +0,0 @@
|
|||
USING: parser-combinators.regexp tools.test kernel ;
|
||||
IN: parser-combinators.regexp.tests
|
||||
|
||||
[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a?" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "." f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "." f <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "." f <regexp> matches? ] unit-test
|
||||
! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" ".+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" ".+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "(a)" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
|
||||
|
||||
! [ "^" "[^]" f <regexp> matches? ] must-fail
|
||||
[ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "0" "[^\\d]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\d]" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\u000078" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\u000078" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "x" "\\." f <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "\\." f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "aaaab" "a+ab" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaxb" "a+ab" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a+cb" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaab" "a++ab" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a++cb" f <regexp> matches? ] unit-test
|
||||
|
||||
[ 3 ] [ "aaacb" "a*" f <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "a+?" f <regexp> match-head ] unit-test
|
||||
[ 2 ] [ "aaacb" "aa?" f <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "aa??" f <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa?c" f <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa??c" f <regexp> match-head ] unit-test
|
||||
|
||||
[ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
|
||||
[ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
|
||||
[ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
[ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
|
||||
[ ] [
|
||||
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
|
||||
f <regexp> drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "fxxbar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
|
||||
|
||||
[ 3 ] [ "foobar" "foo(?=bar)" f <regexp> match-head ] unit-test
|
||||
[ f ] [ "foobxr" "foo(?=bar)" f <regexp> match-head ] unit-test
|
||||
|
||||
[ f ] [ "foobxr" "foo\\z" f <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "foo" "foo\\z" f <regexp> match-head ] unit-test
|
||||
|
||||
[ 3 ] [ "foo bar" "foo\\b" f <regexp> match-head ] unit-test
|
||||
[ f ] [ "fooxbar" "foo\\b" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "foo" "foo\\b" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "foo bar" "foo\\b bar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "fooxbar" "foo\\bxbar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foo" "foo\\bbar" f <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "foo bar" "foo\\B" f <regexp> matches? ] unit-test
|
||||
[ 3 ] [ "fooxbar" "foo\\B" f <regexp> match-head ] unit-test
|
||||
[ t ] [ "foo" "foo\\B" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
|
||||
[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
|
||||
[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
|
||||
|
||||
! Bug in parsing word
|
||||
[ t ] [
|
||||
"a"
|
||||
R' a'
|
||||
matches?
|
||||
] unit-test
|
||||
|
|
@ -1,330 +0,0 @@
|
|||
USING: arrays combinators kernel lists math math.parser
|
||||
namespaces parser lexer parser-combinators
|
||||
parser-combinators.simple promises quotations sequences strings
|
||||
math.order assocs prettyprint.backend prettyprint.custom memoize
|
||||
ascii unicode.categories combinators.short-circuit
|
||||
accessors make io ;
|
||||
IN: parser-combinators.regexp
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: ignore-case?
|
||||
|
||||
: char=-quot ( ch -- quot )
|
||||
ignore-case? get
|
||||
[ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
|
||||
curry ;
|
||||
|
||||
: char-between?-quot ( ch1 ch2 -- quot )
|
||||
ignore-case? get
|
||||
[ [ ch>upper ] bi@ [ [ ch>upper ] 2dip between? ] ]
|
||||
[ [ between? ] ]
|
||||
if 2curry ;
|
||||
|
||||
: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
|
||||
|
||||
: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ascii? ( n -- ? )
|
||||
0 HEX: 7f between? ;
|
||||
|
||||
: octal-digit? ( n -- ? )
|
||||
CHAR: 0 CHAR: 7 between? ;
|
||||
|
||||
: decimal-digit? ( n -- ? )
|
||||
CHAR: 0 CHAR: 9 between? ;
|
||||
|
||||
: hex-digit? ( n -- ? )
|
||||
dup decimal-digit?
|
||||
over CHAR: a CHAR: f between? or
|
||||
swap CHAR: A CHAR: F between? or ;
|
||||
|
||||
: control-char? ( n -- ? )
|
||||
dup 0 HEX: 1f between?
|
||||
swap HEX: 7f = or ;
|
||||
|
||||
: punct? ( n -- ? )
|
||||
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
|
||||
|
||||
: c-identifier-char? ( ch -- ? )
|
||||
dup alpha? swap CHAR: _ = or ;
|
||||
|
||||
: java-blank? ( n -- ? )
|
||||
{
|
||||
CHAR: \s
|
||||
CHAR: \t CHAR: \n CHAR: \r
|
||||
HEX: c HEX: 7 HEX: 1b
|
||||
} member? ;
|
||||
|
||||
: java-printable? ( n -- ? )
|
||||
dup alpha? swap punct? or ;
|
||||
|
||||
: 'ordinary-char' ( -- parser )
|
||||
[ "\\^*+?|(){}[$" member? not ] satisfy
|
||||
[ char=-quot ] <@ ;
|
||||
|
||||
: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
|
||||
|
||||
: 'octal' ( -- parser )
|
||||
"0" token 'octal-digit' 1 3 from-m-to-n &>
|
||||
[ oct> ] <@ ;
|
||||
|
||||
: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
|
||||
|
||||
: 'hex' ( -- parser )
|
||||
"x" token 'hex-digit' 2 exactly-n &>
|
||||
"u" token 'hex-digit' 6 exactly-n &> <|>
|
||||
[ hex> ] <@ ;
|
||||
|
||||
: satisfy-tokens ( assoc -- parser )
|
||||
[ [ token ] dip <@literal ] { } assoc>map <or-parser> ;
|
||||
|
||||
: 'simple-escape-char' ( -- parser )
|
||||
{
|
||||
{ "\\" CHAR: \\ }
|
||||
{ "t" CHAR: \t }
|
||||
{ "n" CHAR: \n }
|
||||
{ "r" CHAR: \r }
|
||||
{ "f" HEX: c }
|
||||
{ "a" HEX: 7 }
|
||||
{ "e" HEX: 1b }
|
||||
} [ char=-quot ] assoc-map satisfy-tokens ;
|
||||
|
||||
: 'predefined-char-class' ( -- parser )
|
||||
{
|
||||
{ "d" [ digit? ] }
|
||||
{ "D" [ digit? not ] }
|
||||
{ "s" [ java-blank? ] }
|
||||
{ "S" [ java-blank? not ] }
|
||||
{ "w" [ c-identifier-char? ] }
|
||||
{ "W" [ c-identifier-char? not ] }
|
||||
} satisfy-tokens ;
|
||||
|
||||
: 'posix-character-class' ( -- parser )
|
||||
{
|
||||
{ "Lower" [ letter? ] }
|
||||
{ "Upper" [ LETTER? ] }
|
||||
{ "ASCII" [ ascii? ] }
|
||||
{ "Alpha" [ Letter? ] }
|
||||
{ "Digit" [ digit? ] }
|
||||
{ "Alnum" [ alpha? ] }
|
||||
{ "Punct" [ punct? ] }
|
||||
{ "Graph" [ java-printable? ] }
|
||||
{ "Print" [ java-printable? ] }
|
||||
{ "Blank" [ " \t" member? ] }
|
||||
{ "Cntrl" [ control-char? ] }
|
||||
{ "XDigit" [ hex-digit? ] }
|
||||
{ "Space" [ java-blank? ] }
|
||||
} satisfy-tokens "p{" "}" surrounded-by ;
|
||||
|
||||
: 'simple-escape' ( -- parser )
|
||||
'octal'
|
||||
'hex' <|>
|
||||
"c" token [ LETTER? ] satisfy &> <|>
|
||||
any-char-parser <|>
|
||||
[ char=-quot ] <@ ;
|
||||
|
||||
: 'escape' ( -- parser )
|
||||
"\\" token
|
||||
'simple-escape-char'
|
||||
'predefined-char-class' <|>
|
||||
'posix-character-class' <|>
|
||||
'simple-escape' <|> &> ;
|
||||
|
||||
: 'any-char' ( -- parser )
|
||||
"." token [ drop t ] <@literal ;
|
||||
|
||||
: 'char' ( -- parser )
|
||||
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
|
||||
|
||||
DEFER: 'regexp'
|
||||
|
||||
TUPLE: group-result str ;
|
||||
|
||||
C: <group-result> group-result
|
||||
|
||||
: 'non-capturing-group' ( -- parser )
|
||||
"?:" token 'regexp' &> ;
|
||||
|
||||
: 'positive-lookahead-group' ( -- parser )
|
||||
"?=" token 'regexp' &> [ ensure ] <@ ;
|
||||
|
||||
: 'negative-lookahead-group' ( -- parser )
|
||||
"?!" token 'regexp' &> [ ensure-not ] <@ ;
|
||||
|
||||
: 'simple-group' ( -- parser )
|
||||
'regexp' [ [ <group-result> ] <@ ] <@ ;
|
||||
|
||||
: 'group' ( -- parser )
|
||||
'non-capturing-group'
|
||||
'positive-lookahead-group'
|
||||
'negative-lookahead-group'
|
||||
'simple-group' <|> <|> <|>
|
||||
"(" ")" surrounded-by ;
|
||||
|
||||
: 'range' ( -- parser )
|
||||
[ CHAR: ] = not ] satisfy "-" token <&
|
||||
[ CHAR: ] = not ] satisfy <&>
|
||||
[ first2 char-between?-quot ] <@ ;
|
||||
|
||||
: 'character-class-term' ( -- parser )
|
||||
'range'
|
||||
'escape' <|>
|
||||
[ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
|
||||
|
||||
: 'positive-character-class' ( -- parser )
|
||||
"]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
|
||||
'character-class-term' <+> <|>
|
||||
[ [ 1|| ] curry ] <@ ;
|
||||
|
||||
: 'negative-character-class' ( -- parser )
|
||||
"^" token 'positive-character-class' &>
|
||||
[ [ not ] append ] <@ ;
|
||||
|
||||
: 'character-class' ( -- parser )
|
||||
'negative-character-class' 'positive-character-class' <|>
|
||||
"[" "]" surrounded-by [ satisfy ] <@ ;
|
||||
|
||||
: 'escaped-seq' ( -- parser )
|
||||
any-char-parser <*>
|
||||
[ ignore-case? get <token-parser> ] <@
|
||||
"\\Q" "\\E" surrounded-by ;
|
||||
|
||||
: 'break' ( quot -- parser )
|
||||
satisfy ensure epsilon just <|> ;
|
||||
|
||||
: 'break-escape' ( -- parser )
|
||||
"$" token [ "\r\n" member? ] 'break' <@literal
|
||||
"\\b" token [ blank? ] 'break' <@literal <|>
|
||||
"\\B" token [ blank? not ] 'break' <@literal <|>
|
||||
"\\z" token epsilon just <@literal <|> ;
|
||||
|
||||
: 'simple' ( -- parser )
|
||||
'escaped-seq'
|
||||
'break-escape' <|>
|
||||
'group' <|>
|
||||
'character-class' <|>
|
||||
'char' <|> ;
|
||||
|
||||
: 'exactly-n' ( -- parser )
|
||||
'integer' [ exactly-n ] <@delay ;
|
||||
|
||||
: 'at-least-n' ( -- parser )
|
||||
'integer' "," token <& [ at-least-n ] <@delay ;
|
||||
|
||||
: 'at-most-n' ( -- parser )
|
||||
"," token 'integer' &> [ at-most-n ] <@delay ;
|
||||
|
||||
: 'from-m-to-n' ( -- parser )
|
||||
'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
|
||||
|
||||
: 'greedy-interval' ( -- parser )
|
||||
'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
|
||||
|
||||
: 'interval' ( -- parser )
|
||||
'greedy-interval'
|
||||
'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
|
||||
'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
|
||||
"{" "}" surrounded-by ;
|
||||
|
||||
: 'repetition' ( -- parser )
|
||||
! Posessive
|
||||
"*+" token [ <!*> ] <@literal
|
||||
"++" token [ <!+> ] <@literal <|>
|
||||
"?+" token [ <!?> ] <@literal <|>
|
||||
! Reluctant
|
||||
"*?" token [ <(*)> ] <@literal <|>
|
||||
"+?" token [ <(+)> ] <@literal <|>
|
||||
"??" token [ <(?)> ] <@literal <|>
|
||||
! Greedy
|
||||
"*" token [ <*> ] <@literal <|>
|
||||
"+" token [ <+> ] <@literal <|>
|
||||
"?" token [ <?> ] <@literal <|> ;
|
||||
|
||||
: 'dummy' ( -- parser )
|
||||
epsilon [ ] <@literal ;
|
||||
|
||||
MEMO: 'term' ( -- parser )
|
||||
'simple'
|
||||
'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
|
||||
<!+> [ <and-parser> ] <@ ;
|
||||
|
||||
LAZY: 'regexp' ( -- parser )
|
||||
'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
|
||||
! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
! &> [ "caret" print ] <@ <|>
|
||||
! 'term' "|" token nonempty-list-of [ <or-parser> ] <@
|
||||
! "$" token <& [ "dollar" print ] <@ <|>
|
||||
! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
|
||||
! "$" token [ "caret dollar" print ] <@ <& <|> ;
|
||||
|
||||
TUPLE: regexp source parser ignore-case? ;
|
||||
|
||||
: <regexp> ( string ignore-case? -- regexp )
|
||||
[
|
||||
ignore-case? [
|
||||
dup 'regexp' just parse-1
|
||||
] with-variable
|
||||
] keep regexp boa ;
|
||||
|
||||
: do-ignore-case ( string regexp -- string regexp )
|
||||
dup ignore-case?>> [ [ >upper ] dip ] when ;
|
||||
|
||||
: matches? ( string regexp -- ? )
|
||||
do-ignore-case parser>> just parse nil? not ;
|
||||
|
||||
: match-head ( string regexp -- end )
|
||||
do-ignore-case parser>> parse dup nil?
|
||||
[ drop f ] [ car unparsed>> from>> ] if ;
|
||||
|
||||
! Literal syntax for regexps
|
||||
: parse-options ( string -- ? )
|
||||
#! Lame
|
||||
{
|
||||
{ "" [ f ] }
|
||||
{ "i" [ t ] }
|
||||
} case ;
|
||||
|
||||
: parse-regexp ( accum end -- accum )
|
||||
lexer get dup skip-blank
|
||||
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
|
||||
lexer get dup still-parsing-line?
|
||||
[ (parse-token) parse-options ] [ drop f ] if
|
||||
<regexp> parsed ;
|
||||
|
||||
: R! CHAR: ! parse-regexp ; parsing
|
||||
: R" CHAR: " parse-regexp ; parsing
|
||||
: R# CHAR: # parse-regexp ; parsing
|
||||
: R' CHAR: ' parse-regexp ; parsing
|
||||
: R( CHAR: ) parse-regexp ; parsing
|
||||
: R/ CHAR: / parse-regexp ; parsing
|
||||
: R@ CHAR: @ parse-regexp ; parsing
|
||||
: R[ CHAR: ] parse-regexp ; parsing
|
||||
: R` CHAR: ` parse-regexp ; parsing
|
||||
: R{ CHAR: } parse-regexp ; parsing
|
||||
: R| CHAR: | parse-regexp ; parsing
|
||||
|
||||
: find-regexp-syntax ( string -- prefix suffix )
|
||||
{
|
||||
{ "R/ " "/" }
|
||||
{ "R! " "!" }
|
||||
{ "R\" " "\"" }
|
||||
{ "R# " "#" }
|
||||
{ "R' " "'" }
|
||||
{ "R( " ")" }
|
||||
{ "R@ " "@" }
|
||||
{ "R[ " "]" }
|
||||
{ "R` " "`" }
|
||||
{ "R{ " "}" }
|
||||
{ "R| " "|" }
|
||||
} swap [ subseq? not nip ] curry assoc-find drop ;
|
||||
|
||||
M: regexp pprint*
|
||||
[
|
||||
dup source>>
|
||||
dup find-regexp-syntax swap % swap % %
|
||||
dup ignore-case?>> [ "i" % ] when
|
||||
] "" make
|
||||
swap present-text ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Regular expressions
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
parsing
|
||||
text
|
||||
1
extra/parser-combinators/regexp/authors.txt → extra/site-watcher/authors.txt
Executable file → Normal file
1
extra/parser-combinators/regexp/authors.txt → extra/site-watcher/authors.txt
Executable file → Normal file
|
|
@ -1,2 +1 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs help.markup help.syntax kernel urls alarms calendar ;
|
||||
IN: site-watcher
|
||||
|
||||
HELP: run-site-watcher
|
||||
{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
|
||||
|
||||
HELP: running-site-watcher
|
||||
{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
|
||||
|
||||
HELP: site-watcher-from
|
||||
{ $var-description "The email address from which site-watcher sends emails." } ;
|
||||
|
||||
HELP: sites
|
||||
{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
|
||||
|
||||
HELP: watch-site
|
||||
{ $values
|
||||
{ "emails" "a string containing an email address, or an array of such" }
|
||||
{ "url" url }
|
||||
}
|
||||
{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
|
||||
|
||||
HELP: watch-sites
|
||||
{ $values
|
||||
{ "assoc" assoc }
|
||||
{ "alarm" alarm }
|
||||
}
|
||||
{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
|
||||
|
||||
HELP: site-watcher-frequency
|
||||
{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
|
||||
|
||||
HELP: unwatch-site
|
||||
{ $values
|
||||
{ "emails" "a string containing an email, or an array of such" }
|
||||
{ "url" url }
|
||||
}
|
||||
{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
|
||||
|
||||
HELP: delete-site
|
||||
{ $values
|
||||
{ "url" url }
|
||||
}
|
||||
{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
|
||||
|
||||
ARTICLE: "site-watcher" "Site watcher"
|
||||
"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
|
||||
"To monitor a site:"
|
||||
{ $subsection watch-site }
|
||||
"To stop email addresses from being notified if a site's status changes:"
|
||||
{ $subsection unwatch-site }
|
||||
"To stop monitoring a site for all email addresses:"
|
||||
{ $subsection delete-site }
|
||||
"To run site-watcher using the sites variable:"
|
||||
{ $subsection run-site-watcher }
|
||||
;
|
||||
|
||||
ABOUT: "site-watcher"
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alarms assocs calendar combinators
|
||||
continuations fry http.client io.streams.string kernel init
|
||||
namespaces prettyprint smtp arrays sequences math math.parser
|
||||
strings sets ;
|
||||
IN: site-watcher
|
||||
|
||||
SYMBOL: sites
|
||||
|
||||
SYMBOL: site-watcher-from
|
||||
|
||||
sites [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: watching emails url last-up up? send-email? error ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ?1array ( array/object -- array )
|
||||
dup array? [ 1array ] unless ; inline
|
||||
|
||||
: <watching> ( emails url -- watching )
|
||||
watching new
|
||||
swap >>url
|
||||
swap ?1array >>emails
|
||||
now >>last-up
|
||||
t >>up? ;
|
||||
|
||||
ERROR: not-watching-site url status ;
|
||||
|
||||
: set-site-flags ( watching new-up? -- watching )
|
||||
[ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
|
||||
|
||||
: site-bad ( watching error -- )
|
||||
>>error f set-site-flags drop ;
|
||||
|
||||
: site-good ( watching -- )
|
||||
f >>error
|
||||
t set-site-flags
|
||||
now >>last-up drop ;
|
||||
|
||||
: check-sites ( assoc -- )
|
||||
[
|
||||
swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
|
||||
] assoc-each ;
|
||||
|
||||
: site-up-email ( email watching -- email )
|
||||
last-up>> now swap time- duration>minutes 60 /mod
|
||||
[ >integer number>string ] bi@
|
||||
[ " hours, " append ] [ " minutes" append ] bi* append
|
||||
"Site was down for (at least): " prepend >>body ;
|
||||
|
||||
: ?unparse ( string/object -- string )
|
||||
dup string? [ unparse ] unless ; inline
|
||||
|
||||
: site-down-email ( email watching -- email )
|
||||
error>> ?unparse >>body ;
|
||||
|
||||
: send-report ( watching -- )
|
||||
[ <email> ] dip
|
||||
{
|
||||
[ emails>> >>to ]
|
||||
[ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
|
||||
[ dup up?>> [ site-up-email ] [ site-down-email ] if ]
|
||||
[ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
|
||||
[ f >>send-email? drop ]
|
||||
} cleave send-email ;
|
||||
|
||||
: report-sites ( assoc -- )
|
||||
[ nip send-email?>> ] assoc-filter
|
||||
[ nip send-report ] assoc-each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: site-watcher-frequency
|
||||
site-watcher-frequency [ 5 minutes ] initialize
|
||||
|
||||
: watch-sites ( assoc -- alarm )
|
||||
'[
|
||||
_ [ check-sites ] [ report-sites ] bi
|
||||
] site-watcher-frequency get every ;
|
||||
|
||||
: watch-site ( emails url -- )
|
||||
sites get ?at [
|
||||
[ [ ?1array ] dip append prune ] change-emails drop
|
||||
] [
|
||||
<watching> dup url>> sites get set-at
|
||||
] if ;
|
||||
|
||||
: delete-site ( url -- )
|
||||
sites get delete-at ;
|
||||
|
||||
: unwatch-site ( emails url -- )
|
||||
[ ?1array ] dip
|
||||
sites get ?at [
|
||||
[ diff ] change-emails dup emails>> empty? [
|
||||
url>> delete-site
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] [
|
||||
nip delete-site
|
||||
] if ;
|
||||
|
||||
SYMBOL: running-site-watcher
|
||||
|
||||
: run-site-watcher ( -- )
|
||||
running-site-watcher get-global [
|
||||
sites get-global watch-sites running-site-watcher set-global
|
||||
] unless ;
|
||||
|
||||
[ f running-site-watcher set-global ] "site-watcher" add-init-hook
|
||||
|
||||
MAIN: run-site-watcher
|
||||
|
|
@ -17,11 +17,11 @@ HELP: >avl
|
|||
HELP: avl
|
||||
{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ;
|
||||
|
||||
ARTICLE: { "avl" "intro" } "AVL trees"
|
||||
ARTICLE: "trees.avl" "AVL trees"
|
||||
"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol."
|
||||
{ $subsection avl }
|
||||
{ $subsection <avl> }
|
||||
{ $subsection >avl }
|
||||
{ $subsection POSTPONE: AVL{ } ;
|
||||
|
||||
ABOUT: { "avl" "intro" }
|
||||
ABOUT: "trees.avl"
|
||||
|
|
@ -1,32 +1,33 @@
|
|||
USING: kernel tools.test trees trees.avl math random sequences assocs ;
|
||||
USING: kernel tools.test trees trees.avl math random sequences
|
||||
assocs accessors ;
|
||||
IN: trees.avl.tests
|
||||
|
||||
[ "key1" 0 "key2" 0 ] [
|
||||
T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 }
|
||||
[ single-rotate ] go-left
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>>
|
||||
] unit-test
|
||||
|
||||
[ "key1" 0 "key2" 0 ] [
|
||||
T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 }
|
||||
[ select-rotate ] go-left
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>>
|
||||
] unit-test
|
||||
|
||||
[ "key1" 0 "key2" 0 ] [
|
||||
T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
|
||||
[ single-rotate ] go-right
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>>
|
||||
] unit-test
|
||||
|
||||
[ "key1" 0 "key2" 0 ] [
|
||||
T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
|
||||
[ select-rotate ] go-right
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>>
|
||||
] unit-test
|
||||
|
||||
[ "key1" -1 "key2" 0 "key3" 0 ]
|
||||
|
|
@ -34,55 +35,55 @@ IN: trees.avl.tests
|
|||
T{ avl-node f "key2" f
|
||||
T{ avl-node f "key3" f f f 1 } f -1 } 2 }
|
||||
[ double-rotate ] go-left
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
[ "key1" 0 "key2" 0 "key3" 0 ]
|
||||
[ T{ avl-node f "key1" f f
|
||||
T{ avl-node f "key2" f
|
||||
T{ avl-node f "key3" f f f 0 } f -1 } 2 }
|
||||
[ double-rotate ] go-left
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
[ "key1" 0 "key2" 1 "key3" 0 ]
|
||||
[ T{ avl-node f "key1" f f
|
||||
T{ avl-node f "key2" f
|
||||
T{ avl-node f "key3" f f f -1 } f -1 } 2 }
|
||||
[ double-rotate ] go-left
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
|
||||
[ "key1" 1 "key2" 0 "key3" 0 ]
|
||||
[ T{ avl-node f "key1" f
|
||||
T{ avl-node f "key2" f f
|
||||
T{ avl-node f "key3" f f f -1 } 1 } f -2 }
|
||||
[ double-rotate ] go-right
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
[ "key1" 0 "key2" 0 "key3" 0 ]
|
||||
[ T{ avl-node f "key1" f
|
||||
T{ avl-node f "key2" f f
|
||||
T{ avl-node f "key3" f f f 0 } 1 } f -2 }
|
||||
[ double-rotate ] go-right
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
[ "key1" 0 "key2" -1 "key3" 0 ]
|
||||
[ T{ avl-node f "key1" f
|
||||
T{ avl-node f "key2" f f
|
||||
T{ avl-node f "key3" f f f 1 } 1 } f -2 }
|
||||
[ double-rotate ] go-right
|
||||
[ node-right dup node-key swap avl-node-balance ] keep
|
||||
[ node-left dup node-key swap avl-node-balance ] keep
|
||||
dup node-key swap avl-node-balance ] unit-test
|
||||
[ right>> dup key>> swap balance>> ] keep
|
||||
[ left>> dup key>> swap balance>> ] keep
|
||||
dup key>> swap balance>> ] unit-test
|
||||
|
||||
[ "eight" ] [
|
||||
<avl> "seven" 7 pick set-at
|
||||
"eight" 8 pick set-at "nine" 9 pick set-at
|
||||
tree-root node-value
|
||||
root>> value>>
|
||||
] unit-test
|
||||
|
||||
[ "another eight" ] [ ! ERROR!
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel generic math math.functions
|
||||
math.parser namespaces io prettyprint.backend sequences trees
|
||||
assocs parser accessors math.order ;
|
||||
math.parser namespaces io sequences trees
|
||||
assocs parser accessors math.order prettyprint.custom ;
|
||||
IN: trees.avl
|
||||
|
||||
TUPLE: avl < tree ;
|
||||
|
|
@ -49,7 +49,7 @@ TUPLE: avl-node < node balance ;
|
|||
[ double-rotate ] [ single-rotate ] if ;
|
||||
|
||||
: balance-insert ( node -- node taller? )
|
||||
dup avl-node-balance {
|
||||
dup balance>> {
|
||||
{ [ dup zero? ] [ drop f ] }
|
||||
{ [ dup abs 2 = ]
|
||||
[ sgn neg [ select-rotate ] with-side f ] }
|
||||
|
|
@ -59,16 +59,16 @@ TUPLE: avl-node < node balance ;
|
|||
DEFER: avl-set
|
||||
|
||||
: avl-insert ( value key node -- node taller? )
|
||||
2dup node-key before? left right ? [
|
||||
2dup key>> before? left right ? [
|
||||
[ node-link avl-set ] keep swap
|
||||
>r tuck set-node-link r>
|
||||
[ tuck set-node-link ] dip
|
||||
[ dup current-side get increase-balance balance-insert ]
|
||||
[ f ] if
|
||||
] with-side ;
|
||||
|
||||
: (avl-set) ( value key node -- node taller? )
|
||||
2dup node-key = [
|
||||
-rot pick set-node-key over set-node-value f
|
||||
2dup key>> = [
|
||||
-rot pick (>>key) over (>>value) f
|
||||
] [ avl-insert ] if ;
|
||||
|
||||
: avl-set ( value key node -- node taller? )
|
||||
|
|
@ -78,15 +78,15 @@ M: avl set-at ( value key node -- node )
|
|||
[ avl-set drop ] change-root drop ;
|
||||
|
||||
: delete-select-rotate ( node -- node shorter? )
|
||||
dup node+link avl-node-balance zero? [
|
||||
current-side get neg over set-avl-node-balance
|
||||
current-side get over node+link set-avl-node-balance rotate f
|
||||
dup node+link balance>> zero? [
|
||||
current-side get neg over (>>balance)
|
||||
current-side get over node+link (>>balance) rotate f
|
||||
] [
|
||||
select-rotate t
|
||||
] if ;
|
||||
|
||||
: rebalance-delete ( node -- node shorter? )
|
||||
dup avl-node-balance {
|
||||
dup balance>> {
|
||||
{ [ dup zero? ] [ drop t ] }
|
||||
{ [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
|
||||
{ [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
|
||||
|
|
@ -94,24 +94,24 @@ M: avl set-at ( value key node -- node )
|
|||
|
||||
: balance-delete ( node -- node shorter? )
|
||||
current-side get over balance>> {
|
||||
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
|
||||
{ [ dup zero? ] [ drop neg over (>>balance) f ] }
|
||||
{ [ dupd = ] [ drop 0 >>balance t ] }
|
||||
[ dupd neg increase-balance rebalance-delete ]
|
||||
} cond ;
|
||||
|
||||
: avl-replace-with-extremity ( to-replace node -- node shorter? )
|
||||
dup node-link [
|
||||
swapd avl-replace-with-extremity >r over set-node-link r>
|
||||
swapd avl-replace-with-extremity [ over set-node-link ] dip
|
||||
[ balance-delete ] [ f ] if
|
||||
] [
|
||||
tuck copy-node-contents node+link t
|
||||
[ copy-node-contents drop ] keep node+link t
|
||||
] if* ;
|
||||
|
||||
: replace-with-a-child ( node -- node shorter? )
|
||||
#! assumes that node is not a leaf, otherwise will recurse forever
|
||||
dup node-link [
|
||||
dupd [ avl-replace-with-extremity ] with-other-side
|
||||
>r over set-node-link r> [ balance-delete ] [ f ] if
|
||||
[ over set-node-link ] dip [ balance-delete ] [ f ] if
|
||||
] [
|
||||
[ replace-with-a-child ] with-other-side
|
||||
] if* ;
|
||||
|
|
@ -130,11 +130,12 @@ GENERIC: avl-delete ( key node -- node shorter? deleted? )
|
|||
M: f avl-delete ( key f -- f f f ) nip f f ;
|
||||
|
||||
: (avl-delete) ( key node -- node shorter? deleted? )
|
||||
tuck node-link avl-delete >r >r over set-node-link r>
|
||||
[ balance-delete r> ] [ f r> ] if ;
|
||||
tuck node-link avl-delete [
|
||||
[ over set-node-link ] dip [ balance-delete ] [ f ] if
|
||||
] dip ;
|
||||
|
||||
M: avl-node avl-delete ( key node -- node shorter? deleted? )
|
||||
2dup node-key key-side dup zero? [
|
||||
2dup key>> key-side dup zero? [
|
||||
drop nip avl-delete-node t
|
||||
] [
|
||||
[ (avl-delete) ] with-side
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue