Merge branch 'master' of git://factorcode.org/git/factor
* 'master' of git://factorcode.org/git/factor: (66 commits)
Better error message for syntax error in : foo ( : bar
remove some dead code, make spider use count and max-count again
left and right arrow keys move between graphemes in UI
Adding functionality to unicode breaks API for future UI changes
state-parser works with sequences, not strings
rename word
redo spider without dynamic variables
remove duplication, refactor html.parser to use new state parser
redo state parser to avoid dynamic variables
fix help-lint for syndication
Small speedup for code using H{ } clone and with-scope
Small size reduction for deployed images
Tweak some code to reduce deployed image size
syndication: fix help lint
Fix parse-feed for byte arrays
refactor some error handling in peg, more unit tests
Fix C99 complex number support in FFI on Mac OS X/PPC
add unit tests for quoting
Fix model docs
Some cleanup in documents.elements
...
db4
Aaron Schaefer
commit
a4800878e1
Binary file not shown.
13
Makefile
13
Makefile
|
|
@ -11,6 +11,7 @@ IMAGE = factor.image
|
|||
BUNDLE = Factor.app
|
||||
LIBPATH = -L/usr/X11R6/lib
|
||||
CFLAGS = -Wall
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
||||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
|
|
@ -140,9 +141,10 @@ wince-arm:
|
|||
|
||||
macosx.app: factor
|
||||
mkdir -p $(BUNDLE)/Contents/MacOS
|
||||
mkdir -p $(BUNDLE)/Contents/Frameworks
|
||||
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
ln -s Factor.app/Contents/MacOS/factor ./factor
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
|
||||
|
||||
install_name_tool \
|
||||
-change libfactor.dylib \
|
||||
|
|
@ -159,16 +161,19 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
|
|||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-ffi-test: $(TEST_OBJS)
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS)
|
||||
factor-ffi-test: vm/ffi_test.o
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor.{a,so,dylib}
|
||||
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
|
||||
|
||||
vm/resources.o:
|
||||
$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
||||
vm/ffi_test.o: vm/ffi_test.c
|
||||
$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
|
||||
|
||||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
|
|
|
|||
|
|
@ -18,5 +18,4 @@ TUPLE: library path abi dll ;
|
|||
library dup [ dll>> ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
[ dup [ normalize-path ] when ] dip
|
||||
<library> swap libraries get set-at ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax io kernel namespaces core-foundation
|
||||
core-foundation.strings cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences threads init summary kernel.private
|
||||
cocoa.runtime sequences init summary kernel.private
|
||||
assocs ;
|
||||
IN: cocoa.application
|
||||
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ SYMBOL: labels
|
|||
V{ } clone literal-table set
|
||||
V{ } clone calls set
|
||||
compiling-word set
|
||||
compiled-stack-traces? compiling-word get f ? add-literal ;
|
||||
compiled-stack-traces? [ compiling-word get add-literal ] when ;
|
||||
|
||||
: generate ( mr -- asm )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,18 +1,20 @@
|
|||
IN: compiler.tests
|
||||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math accessors combinators
|
||||
specialized-arrays.float alien.libraries ;
|
||||
specialized-arrays.float alien.libraries io.pathnames
|
||||
io.backend ;
|
||||
IN: compiler.tests
|
||||
|
||||
<<
|
||||
: libfactor-ffi-tests-path ( -- string )
|
||||
"resource:" (normalize-path)
|
||||
{
|
||||
{ [ os winnt? ] [ "resource:libfactor-ffi-test.dll" ] }
|
||||
{ [ os macosx? ] [ "resource:libfactor-ffi-test.dylib" ] }
|
||||
{ [ os unix? ] [ "resource:libfactor-ffi-test.so" ] }
|
||||
} cond ;
|
||||
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
|
||||
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
|
||||
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
|
||||
} cond append-path ;
|
||||
|
||||
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
|
||||
|
||||
|
|
@ -122,8 +124,6 @@ unit-test
|
|||
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
|
||||
gc ;
|
||||
|
||||
LIBRARY: f-stdcall
|
||||
|
||||
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||
|
||||
|
|
@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
|
||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
||||
"int"
|
||||
"f-stdcall" "ffi_test_31"
|
||||
"f-cdecl" "ffi_test_31"
|
||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
||||
alien-invoke gc 3 ;
|
||||
|
||||
|
|
@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
|
||||
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
||||
"float"
|
||||
"f-stdcall" "ffi_test_31_point_5"
|
||||
"f-cdecl" "ffi_test_31_point_5"
|
||||
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
|
||||
alien-invoke ;
|
||||
|
||||
|
|
|
|||
|
|
@ -312,7 +312,7 @@ generic-comparison-ops [
|
|||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop hashtable new ] ] }
|
||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax alien.strings io.encodings.string kernel
|
||||
sequences byte-arrays io.encodings.utf8 math core-foundation
|
||||
core-foundation.arrays destructors unicode.data ;
|
||||
core-foundation.arrays destructors ;
|
||||
IN: core-foundation.strings
|
||||
|
||||
TYPEDEF: void* CFStringRef
|
||||
|
|
@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
|
|||
: prepare-CFString ( string -- byte-array )
|
||||
[
|
||||
dup HEX: 10ffff >
|
||||
[ drop CHAR: replacement-character ] when
|
||||
[ drop HEX: fffd ] when
|
||||
] map utf8 encode ;
|
||||
|
||||
: <CFString> ( string -- alien )
|
||||
|
|
|
|||
|
|
@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
|
|||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? )
|
||||
c-type return-in-registers?>> ;
|
||||
|
||||
M: ppc %box-small-struct
|
||||
drop "No small structs" throw ;
|
||||
M: ppc %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
|
||||
heap-size 7 LI
|
||||
"box_medium_struct" f %alien-invoke ;
|
||||
|
||||
M: ppc %unbox-small-struct
|
||||
drop "No small structs" throw ;
|
||||
: %unbox-struct-1 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
3 3 0 LWZ ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
4 3 4 LWZ
|
||||
3 3 0 LWZ ;
|
||||
|
||||
: %unbox-struct-4 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
6 3 12 LWZ
|
||||
5 3 8 LWZ
|
||||
4 3 4 LWZ
|
||||
3 3 0 LWZ ;
|
||||
|
||||
M: ppc %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
{ 4 [ %unbox-struct-4 ] }
|
||||
} case ;
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
|
|
@ -673,3 +700,5 @@ USE: vocabs.loader
|
|||
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
|
||||
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
|
||||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
|
|
|
|||
|
|
@ -3,68 +3,72 @@
|
|||
USING: tools.test namespaces documents documents.elements multiline ;
|
||||
IN: document.elements.tests
|
||||
|
||||
<document> "doc" set
|
||||
"123\nabc" "doc" get set-doc-string
|
||||
SYMBOL: doc
|
||||
<document> doc set
|
||||
"123\nabcé" doc get set-doc-string
|
||||
|
||||
! char-elt
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
|
||||
[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
|
||||
|
||||
[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
|
||||
[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
|
||||
[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
|
||||
[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
|
||||
[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
|
||||
[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
|
||||
[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
|
||||
|
||||
! word-elt
|
||||
<document> "doc" set
|
||||
"Hello world\nanother line" "doc" get set-doc-string
|
||||
<document> doc set
|
||||
"Hello world\nanother line" doc get set-doc-string
|
||||
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
|
||||
[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
|
||||
[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
|
||||
|
||||
[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
|
||||
[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
|
||||
[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
|
||||
[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
|
||||
|
||||
[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
|
||||
[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
|
||||
[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
|
||||
[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
|
||||
|
||||
! one-word-elt
|
||||
[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
|
||||
[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
|
||||
|
||||
! line-elt
|
||||
<document> "doc" set
|
||||
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
|
||||
<document> doc set
|
||||
"Hello\nworld, how are\nyou?" doc get set-doc-string
|
||||
|
||||
[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
|
||||
[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
|
||||
[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
|
||||
|
||||
! one-line-elt
|
||||
[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
|
||||
[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
|
||||
[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
|
||||
[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
|
||||
|
||||
! page-elt
|
||||
<document> "doc" set
|
||||
<document> doc set
|
||||
<" First line
|
||||
Second line
|
||||
Third line
|
||||
Fourth line
|
||||
Fifth line
|
||||
Sixth line"> "doc" get set-doc-string
|
||||
Sixth line"> doc get set-doc-string
|
||||
|
||||
[ { 0 0 } ] [ { 3 3 } "doc" get 4 <page-elt> prev-elt ] unit-test
|
||||
[ { 1 2 } ] [ { 5 2 } "doc" get 4 <page-elt> prev-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
|
||||
[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
|
||||
|
||||
[ { 4 3 } ] [ { 0 3 } "doc" get 4 <page-elt> next-elt ] unit-test
|
||||
[ { 5 10 } ] [ { 4 2 } "doc" get 4 <page-elt> next-elt ] unit-test
|
||||
[ { 4 3 } ] [ { 0 3 } doc get 4 <page-elt> next-elt ] unit-test
|
||||
[ { 5 10 } ] [ { 4 2 } doc get 4 <page-elt> next-elt ] unit-test
|
||||
|
||||
! doc-elt
|
||||
[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
|
||||
[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
|
||||
[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
|
||||
[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators documents fry kernel math sequences
|
||||
unicode.categories accessors ;
|
||||
accessors unicode.categories unicode.breaks combinators.short-circuit ;
|
||||
IN: documents.elements
|
||||
|
||||
GENERIC: prev-elt ( loc document elt -- newloc )
|
||||
|
|
@ -20,27 +20,32 @@ SINGLETON: char-elt
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
: prev ( loc document quot: ( loc document -- loc ) -- loc )
|
||||
{
|
||||
{ [ pick { 0 0 } = ] [ 2drop ] }
|
||||
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
: (next-char) ( loc document quot -- loc )
|
||||
: next ( loc document quot: ( loc document -- loc ) -- loc )
|
||||
{
|
||||
{ [ 2over doc-end = ] [ 2drop ] }
|
||||
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
: modify-col ( loc document quot: ( col str -- col' ) -- loc )
|
||||
pick [
|
||||
[ [ first2 swap ] dip doc-line ] dip call
|
||||
] dip =col ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: char-elt prev-elt
|
||||
drop [ drop -1 +col ] (prev-char) ;
|
||||
drop [ [ last-grapheme-from ] modify-col ] prev ;
|
||||
|
||||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
drop [ [ first-grapheme-from ] modify-col ] next ;
|
||||
|
||||
SINGLETON: one-char-elt
|
||||
|
||||
|
|
@ -50,21 +55,16 @@ M: one-char-elt next-elt 2drop ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (word-elt) ( loc document quot -- loc )
|
||||
pick [
|
||||
[ [ first2 swap ] dip doc-line ] dip call
|
||||
] dip =col ; inline
|
||||
|
||||
: ((word-elt)) ( n seq -- n seq ? )
|
||||
: blank-at? ( n seq -- n seq ? )
|
||||
2dup ?nth blank? ;
|
||||
|
||||
: break-detector ( ? -- quot )
|
||||
'[ blank? _ xor ] ; inline
|
||||
|
||||
: (prev-word) ( col str ? -- col )
|
||||
: prev-word ( col str ? -- col )
|
||||
break-detector find-last-from drop ?1+ ;
|
||||
|
||||
: (next-word) ( col str ? -- col )
|
||||
: next-word ( col str ? -- col )
|
||||
[ break-detector find-from drop ] [ drop length ] 2bi or ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -73,23 +73,23 @@ SINGLETON: one-word-elt
|
|||
|
||||
M: one-word-elt prev-elt
|
||||
drop
|
||||
[ [ 1- ] dip f (prev-word) ] (word-elt) ;
|
||||
[ [ 1- ] dip f prev-word ] modify-col ;
|
||||
|
||||
M: one-word-elt next-elt
|
||||
drop
|
||||
[ f (next-word) ] (word-elt) ;
|
||||
[ f next-word ] modify-col ;
|
||||
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
drop
|
||||
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
|
||||
(prev-char) ;
|
||||
[ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
|
||||
prev ;
|
||||
|
||||
M: word-elt next-elt
|
||||
drop
|
||||
[ [ ((word-elt)) (next-word) ] (word-elt) ]
|
||||
(next-char) ;
|
||||
[ [ blank-at? next-word ] modify-col ]
|
||||
next ;
|
||||
|
||||
SINGLETON: one-line-elt
|
||||
|
||||
|
|
@ -118,4 +118,4 @@ SINGLETON: doc-elt
|
|||
|
||||
M: doc-elt prev-elt 3drop { 0 0 } ;
|
||||
|
||||
M: doc-elt next-elt drop nip doc-end ;
|
||||
M: doc-elt next-elt drop nip doc-end ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
|
||||
urls.encoding assocs xml.traversal xml.data ;
|
||||
urls.encoding assocs xml.traversal xml.data sequences random
|
||||
io continuations math ;
|
||||
IN: farkup.tests
|
||||
|
||||
relative-link-prefix off
|
||||
|
|
@ -180,3 +181,29 @@ link-no-follow? off
|
|||
[ "<p><em>italics<strong>both</strong></em>after<strong></strong></p>" ] [ "_italics*both_after*" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
|
||||
[ "<p></p>" ] [ "\\" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
|
||||
|
||||
: random-markup ( -- string )
|
||||
10 [
|
||||
2 random 1 = [
|
||||
{
|
||||
"[["
|
||||
"*"
|
||||
"_"
|
||||
"|"
|
||||
"-"
|
||||
"[{"
|
||||
"\n"
|
||||
} random
|
||||
] [
|
||||
"abc"
|
||||
] if
|
||||
] replicate concat ;
|
||||
|
||||
[ t ] [
|
||||
100 [
|
||||
drop random-markup
|
||||
[ convert-farkup drop t ] [ drop print f ] recover
|
||||
] all?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ DEFER: (parse-paragraph)
|
|||
"|" split1
|
||||
[ "" like dup simple-link-title ] unless*
|
||||
[ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
|
||||
] dip [ (parse-paragraph) cons ] when* ;
|
||||
] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
|
||||
|
||||
: ?first ( seq -- elt ) 0 swap ?nth ;
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
|
|||
] if
|
||||
] if ;
|
||||
|
||||
: take-until ( state delimiter -- string/f state' )
|
||||
: take-until ( state delimiter -- string state'/f )
|
||||
V{ } clone (take-until) ;
|
||||
|
||||
: count= ( string -- n )
|
||||
|
|
@ -186,10 +186,12 @@ DEFER: (parse-paragraph)
|
|||
|
||||
: parse-code ( state -- state' item )
|
||||
dup 1 look CHAR: [ =
|
||||
[ unclip-slice make-paragraph ] [
|
||||
"{" take-until [ rest ] dip
|
||||
"}]" take-until
|
||||
[ code boa ] dip swap
|
||||
[ take-line make-paragraph ] [
|
||||
dup "{" take-until [
|
||||
[ nip rest ] dip
|
||||
"}]" take-until
|
||||
[ code boa ] dip swap
|
||||
] [ drop take-line make-paragraph ] if*
|
||||
] if ;
|
||||
|
||||
: parse-item ( state -- state' item )
|
||||
|
|
|
|||
|
|
@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" }
|
|||
TIP: "You can write graphical applications using the " { $link "ui" } "." ;
|
||||
|
||||
TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
|
||||
|
||||
|
||||
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
|
||||
|
||||
HELP: TIP:
|
||||
{ $syntax "TIP: content ;" }
|
||||
{ $values { "content" "a markup element" } }
|
||||
{ $description "Defines a new tip of the day." } ;
|
||||
|
||||
ARTICLE: "all-tips-of-the-day" "All tips of the day"
|
||||
{ $tips-of-the-day } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,28 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser arrays namespaces sequences random help.markup kernel io
|
||||
io.styles colors.constants ;
|
||||
USING: parser arrays namespaces sequences random help.markup help.stylesheet
|
||||
kernel io io.styles colors.constants definitions accessors ;
|
||||
IN: help.tips
|
||||
|
||||
SYMBOL: tips
|
||||
|
||||
tips [ V{ } clone ] initialize
|
||||
|
||||
SYNTAX: TIP: parse-definition >array tips get push ;
|
||||
TUPLE: tip < identity-tuple content loc ;
|
||||
|
||||
M: tip forget* tips get delq ;
|
||||
|
||||
M: tip where loc>> ;
|
||||
|
||||
M: tip set-where (>>loc) ;
|
||||
|
||||
: <tip> ( content -- tip ) f tip boa ;
|
||||
|
||||
: add-tip ( tip -- ) tips get push ;
|
||||
|
||||
SYNTAX: TIP:
|
||||
parse-definition >array <tip>
|
||||
[ save-location ] [ add-tip ] bi ;
|
||||
|
||||
: a-tip ( -- tip ) tips get random ;
|
||||
|
||||
|
|
@ -20,13 +34,20 @@ H{
|
|||
{ wrap-margin 500 }
|
||||
} tip-of-the-day-style set-global
|
||||
|
||||
: $tip-title ( tip -- )
|
||||
[
|
||||
heading-style get [
|
||||
[ "Tip of the day" ] dip write-object
|
||||
] with-style
|
||||
] ($block) ;
|
||||
|
||||
: $tip-of-the-day ( element -- )
|
||||
drop
|
||||
[
|
||||
tip-of-the-day-style get
|
||||
[
|
||||
last-element off
|
||||
"Tip of the day" $heading a-tip print-element nl
|
||||
a-tip [ $tip-title ] [ content>> print-element nl ] bi
|
||||
"— " print-element "all-tips-of-the-day" ($link)
|
||||
]
|
||||
with-nesting
|
||||
|
|
@ -35,4 +56,6 @@ H{
|
|||
: tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
|
||||
|
||||
: $tips-of-the-day ( element -- )
|
||||
drop tips get [ nl nl ] [ print-element ] interleave ;
|
||||
drop tips get [ nl nl ] [ content>> print-element ] interleave ;
|
||||
|
||||
INSTANCE: tip definition
|
||||
|
|
@ -7,8 +7,12 @@ IN: help.topics
|
|||
|
||||
TUPLE: link name ;
|
||||
|
||||
INSTANCE: link definition
|
||||
|
||||
MIXIN: topic
|
||||
|
||||
INSTANCE: link topic
|
||||
|
||||
INSTANCE: word topic
|
||||
|
||||
GENERIC: >link ( obj -- obj )
|
||||
|
|
|
|||
|
|
@ -34,16 +34,18 @@ M: object specializer-declaration class ;
|
|||
[ specializer-declaration ] map '[ _ declare ] pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
[ "method-generic" word-prop dispatch# object <array> ]
|
||||
[ "method-class" word-prop ]
|
||||
bi prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration '[ _ declare ] prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
[ method-declaration '[ _ declare ] prepend ]
|
||||
[ "method-generic" word-prop "specializer" word-prop ] bi
|
||||
[ specialize-quot ] when* ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
|
|
@ -52,9 +54,11 @@ M: object specializer-declaration class ;
|
|||
|
||||
: specialized-def ( word -- quot )
|
||||
[ def>> ] keep
|
||||
[ dup standard-method? [ specialize-method ] [ drop ] if ]
|
||||
[ "specializer" word-prop [ specialize-quot ] when* ]
|
||||
bi ;
|
||||
dup generic? [ drop ] [
|
||||
[ dup standard-method? [ specialize-method ] [ drop ] if ]
|
||||
[ "specializer" word-prop [ specialize-quot ] when* ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
@ -115,6 +119,6 @@ SYNTAX: HINTS:
|
|||
|
||||
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
|
||||
|
||||
\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
|
||||
\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
|
||||
|
||||
\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays fry
|
||||
specialized-arrays.direct.ushort specialized-arrays.uint
|
||||
specialized-arrays.ushort specialized-arrays.float ;
|
||||
USING: combinators kernel ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
|
||||
|
||||
: bytes-per-pixel ( component-order -- n )
|
||||
{
|
||||
{ L [ 1 ] }
|
||||
{ BGR [ 3 ] }
|
||||
{ RGB [ 3 ] }
|
||||
{ BGRA [ 4 ] }
|
||||
|
|
@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
|||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <groups> [ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-floats ( byte-array -- byte-array )
|
||||
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
|
||||
|
||||
GENERIC: normalize-component-order* ( image component-order -- image )
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
|
||||
|
||||
M: RGBA normalize-component-order* drop ;
|
||||
|
||||
M: R32G32B32A32 normalize-component-order*
|
||||
drop normalize-floats ;
|
||||
|
||||
M: R32G32B32 normalize-component-order*
|
||||
drop normalize-floats add-dummy-alpha ;
|
||||
|
||||
: RGB16>8 ( bitmap -- bitmap' )
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
|
||||
|
||||
M: R16G16B16A16 normalize-component-order*
|
||||
drop RGB16>8 ;
|
||||
|
||||
M: R16G16B16 normalize-component-order*
|
||||
drop RGB16>8 add-dummy-alpha ;
|
||||
|
||||
: 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 BGRA>RGBA ;
|
||||
|
||||
M: RGB normalize-component-order*
|
||||
drop add-dummy-alpha ;
|
||||
|
||||
M: BGR normalize-component-order*
|
||||
drop BGR>RGB add-dummy-alpha ;
|
||||
|
||||
: ARGB>RGBA ( bitmap -- bitmap' )
|
||||
4 <groups> [ unclip suffix ] map B{ } join ; inline
|
||||
|
||||
M: ARGB normalize-component-order*
|
||||
drop ARGB>RGBA ;
|
||||
|
||||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
dup dim>> first 4 * '[
|
||||
_ <groups> reverse concat
|
||||
] change-bitmap
|
||||
f >>upside-down?
|
||||
] when ;
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order
|
||||
RGBA >>component-order ;
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images io.backend
|
||||
accessors images.bitmap images.tiff images images.normalization
|
||||
io.pathnames ;
|
||||
IN: images.loader
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
! Copyright (C) 2009 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays fry
|
||||
specialized-arrays.direct.ushort specialized-arrays.uint
|
||||
specialized-arrays.ushort specialized-arrays.float images ;
|
||||
IN: images.normalization
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <groups> [ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-floats ( byte-array -- byte-array )
|
||||
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
|
||||
|
||||
GENERIC: normalize-component-order* ( image component-order -- image )
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
|
||||
|
||||
M: RGBA normalize-component-order* drop ;
|
||||
|
||||
M: R32G32B32A32 normalize-component-order*
|
||||
drop normalize-floats ;
|
||||
|
||||
M: R32G32B32 normalize-component-order*
|
||||
drop normalize-floats add-dummy-alpha ;
|
||||
|
||||
: RGB16>8 ( bitmap -- bitmap' )
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
|
||||
|
||||
M: R16G16B16A16 normalize-component-order*
|
||||
drop RGB16>8 ;
|
||||
|
||||
M: R16G16B16 normalize-component-order*
|
||||
drop RGB16>8 add-dummy-alpha ;
|
||||
|
||||
: 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 BGRA>RGBA ;
|
||||
|
||||
M: RGB normalize-component-order*
|
||||
drop add-dummy-alpha ;
|
||||
|
||||
M: BGR normalize-component-order*
|
||||
drop BGR>RGB add-dummy-alpha ;
|
||||
|
||||
: ARGB>RGBA ( bitmap -- bitmap' )
|
||||
4 <groups> [ unclip suffix ] map B{ } join ; inline
|
||||
|
||||
M: ARGB normalize-component-order*
|
||||
drop ARGB>RGBA ;
|
||||
|
||||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
dup dim>> first 4 * '[
|
||||
_ <groups> reverse concat
|
||||
] change-bitmap
|
||||
f >>upside-down?
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order
|
||||
RGBA >>component-order ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
USING: images accessors kernel tools.test literals math.ranges
|
||||
byte-arrays ;
|
||||
IN: images.tesselation
|
||||
|
||||
! Check an invariant we depend on
|
||||
[ t ] [
|
||||
<image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 1 2 5 6 } }
|
||||
T{ image f { 2 2 } L f B{ 3 4 7 8 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 9 10 13 14 } }
|
||||
T{ image f { 2 2 } L f B{ 11 12 15 16 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
<image>
|
||||
1 16 [a,b] >byte-array >>bitmap
|
||||
{ 4 4 } >>dim
|
||||
L >>component-order
|
||||
{ 2 2 } tesselate
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 1 2 4 5 } }
|
||||
T{ image f { 1 2 } L f B{ 3 6 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 1 } L f B{ 7 8 } }
|
||||
T{ image f { 1 1 } L f B{ 9 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
<image>
|
||||
1 9 [a,b] >byte-array >>bitmap
|
||||
{ 3 3 } >>dim
|
||||
L >>component-order
|
||||
{ 2 2 } tesselate
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel math grouping fry columns locals accessors
|
||||
images math math.vectors arrays ;
|
||||
IN: images.tesselation
|
||||
|
||||
: group-rows ( bitmap bitmap-dim -- rows )
|
||||
first <sliced-groups> ; inline
|
||||
|
||||
: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
|
||||
second <sliced-groups> ; inline
|
||||
|
||||
: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
|
||||
first '[ _ <sliced-groups> ] map flip ; inline
|
||||
|
||||
: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
|
||||
[ group-rows ] dip
|
||||
[ tesselate-rows ] keep
|
||||
'[ _ tesselate-columns ] map ;
|
||||
|
||||
: tile-width ( tile-bitmap original-image -- width )
|
||||
[ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
|
||||
|
||||
: <tile-image> ( tile-bitmap original-image -- tile-image )
|
||||
clone
|
||||
swap
|
||||
[ concat >>bitmap ]
|
||||
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
|
||||
|
||||
:: tesselate ( image tess-dim -- image-grid )
|
||||
image component-order>> bytes-per-pixel :> bpp
|
||||
image dim>> { bpp 1 } v* :> image-dim'
|
||||
tess-dim { bpp 1 } v* :> tess-dim'
|
||||
image bitmap>> image-dim' tess-dim' tesselate-bitmap
|
||||
[ [ image <tile-image> ] map ] map ;
|
||||
|
|
@ -65,9 +65,9 @@ ERROR: file-not-found ;
|
|||
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
|
||||
] [
|
||||
drop f
|
||||
] recover ;
|
||||
] recover ; inline
|
||||
|
||||
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
|
||||
'[ _ _ find-all-files ] map concat ;
|
||||
'[ _ _ find-all-files ] map concat ; inline
|
||||
|
||||
os windows? [ "io.directories.search.windows" require ] when
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.encodings kernel math io.encodings.private io.encodings.iana ;
|
||||
USING: io io.encodings kernel math io.encodings.private ;
|
||||
IN: io.encodings.ascii
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -19,6 +19,4 @@ M: ascii encode-char
|
|||
128 encode-if< ;
|
||||
|
||||
M: ascii decode-char
|
||||
128 decode-if< ;
|
||||
|
||||
ascii "ANSI_X3.4-1968" register-encoding
|
||||
128 decode-if< ;
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings values io.files assocs
|
||||
splitting sequences io namespaces sets io.encodings.utf8 ;
|
||||
splitting sequences io namespaces sets
|
||||
io.encodings.ascii io.encodings.utf8 ;
|
||||
IN: io.encodings.iana
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -52,3 +53,5 @@ e>n-table [ initial-e>n ] initialize
|
|||
[ n>e-table get-global set-at ] with each
|
||||
] [ "Bad encoding registration" throw ] if*
|
||||
] [ swap e>n-table get-global set-at ] 2bi ;
|
||||
|
||||
ascii "ANSI_X3.4-1968" register-encoding
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: tools.test io.streams.byte-array io.encodings.binary
|
||||
io.encodings.utf8 io kernel arrays strings ;
|
||||
io.encodings.utf8 io kernel arrays strings namespaces ;
|
||||
|
||||
[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
|
||||
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
|
||||
|
|
@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
|
|||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
|
||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
|
||||
|
||||
[ B{ 121 120 } 0 ] [
|
||||
B{ 0 121 120 0 0 0 0 0 0 } binary
|
||||
[ 1 read drop "\0" read-until ] with-byte-reader
|
||||
] unit-test
|
||||
|
||||
[ 1 1 4 11 f ] [
|
||||
B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
|
||||
[
|
||||
read1
|
||||
0 seek-absolute input-stream get stream-seek
|
||||
read1
|
||||
2 seek-relative input-stream get stream-seek
|
||||
read1
|
||||
-2 seek-end input-stream get stream-seek
|
||||
read1
|
||||
0 seek-end input-stream get stream-seek
|
||||
read1
|
||||
] with-byte-reader
|
||||
] unit-test
|
||||
|
|
@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
|
|||
swap {
|
||||
{ seek-absolute [ (>>i) ] }
|
||||
{ seek-relative [ [ + ] change-i drop ] }
|
||||
{ seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
|
||||
{ seek-end [ [ underlying>> length + ] keep (>>i) ] }
|
||||
[ bad-seek-type ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ IN: math.bitwise
|
|||
|
||||
! flags
|
||||
MACRO: flags ( values -- )
|
||||
[ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
|
||||
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
|
||||
|
||||
! bitfield
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -7,7 +7,11 @@ IN: math.blas.ffi
|
|||
{ [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
|
||||
{ [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
|
||||
{
|
||||
[ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
|
||||
[ "libblas.so" gfortran-abi add-fortran-library ]
|
||||
}
|
||||
{ [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
|
||||
[ "libblas.so" f2c-abi add-fortran-library ]
|
||||
} cond
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -5,12 +5,13 @@ IN: models
|
|||
HELP: model
|
||||
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
|
||||
{ $list
|
||||
{ { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||
{ { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||
{ { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||
{ { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||
{ { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||
{ { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||
{ { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||
{ { $slot "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||
{ { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" }
|
||||
}
|
||||
"Other classes may delegate to " { $link model } "."
|
||||
"Other classes may inherit from " { $link model } "."
|
||||
} ;
|
||||
|
||||
HELP: <model>
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@ HELP: gl-line
|
|||
{ $description "Draws a line between two points." } ;
|
||||
|
||||
HELP: gl-fill-rect
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gl-rect
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gen-gl-buffer
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.parser opengl.gl opengl.glu
|
||||
combinators arrays sequences splitting words byte-arrays assocs
|
||||
namespaces math.vectors math.parser opengl.gl opengl.glu combinators
|
||||
combinators.smart arrays sequences splitting words byte-arrays assocs
|
||||
colors colors.constants accessors generalizations locals fry
|
||||
specialized-arrays.float specialized-arrays.uint ;
|
||||
IN: opengl
|
||||
|
|
@ -28,7 +28,7 @@ IN: opengl
|
|||
over glEnableClientState dip glDisableClientState ; inline
|
||||
|
||||
: words>values ( word/value-seq -- value-seq )
|
||||
[ dup word? [ execute ] when ] map ;
|
||||
[ ?execute ] map ;
|
||||
|
||||
: (all-enabled) ( seq quot -- )
|
||||
over [ glEnable ] each dip [ glDisable ] each ; inline
|
||||
|
|
@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: gl-line ( a b -- )
|
||||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||
|
||||
: (rect-vertices) ( dim -- vertices )
|
||||
:: (rect-vertices) ( loc dim -- vertices )
|
||||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
#! X3100 driver.
|
||||
{
|
||||
[ drop 0.5 0.5 ]
|
||||
[ first 0.3 - 0.5 ]
|
||||
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
|
||||
[ second 0.3 - 0.5 swap ]
|
||||
[ drop 0.5 0.5 ]
|
||||
} cleave 10 float-array{ } nsequence ;
|
||||
loc first2 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
[
|
||||
x 0.5 + y 0.5 +
|
||||
x w + 0.3 - y 0.5 +
|
||||
x w + 0.3 - y h + 0.3 -
|
||||
x y h + 0.3 -
|
||||
x 0.5 + y 0.5 +
|
||||
] float-array{ } output>sequence ;
|
||||
|
||||
: rect-vertices ( dim -- )
|
||||
: rect-vertices ( loc dim -- )
|
||||
(rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-rect) ( -- )
|
||||
GL_LINE_STRIP 0 5 glDrawArrays ;
|
||||
|
||||
: gl-rect ( dim -- )
|
||||
: gl-rect ( loc dim -- )
|
||||
rect-vertices (gl-rect) ;
|
||||
|
||||
: (fill-rect-vertices) ( dim -- vertices )
|
||||
{
|
||||
[ drop 0 0 ]
|
||||
[ first 0 ]
|
||||
[ first2 ]
|
||||
[ second 0 swap ]
|
||||
} cleave 8 float-array{ } nsequence ;
|
||||
:: (fill-rect-vertices) ( loc dim -- vertices )
|
||||
loc first2 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
[
|
||||
x y
|
||||
x w + y
|
||||
x w + y h +
|
||||
x y h +
|
||||
] float-array{ } output>sequence ;
|
||||
|
||||
: fill-rect-vertices ( dim -- )
|
||||
: fill-rect-vertices ( loc dim -- )
|
||||
(fill-rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-fill-rect) ( -- )
|
||||
GL_QUADS 0 4 glDrawArrays ;
|
||||
|
||||
: gl-fill-rect ( dim -- )
|
||||
: gl-fill-rect ( loc dim -- )
|
||||
fill-rect-vertices (gl-fill-rect) ;
|
||||
|
||||
: do-attribs ( bits quot -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test opengl.textures opengl.textures.private
|
||||
images kernel namespaces ;
|
||||
opengl.textures.private images kernel namespaces accessors
|
||||
sequences ;
|
||||
IN: opengl.textures.tests
|
||||
|
||||
[ ] [
|
||||
|
|
@ -52,4 +53,17 @@ IN: opengl.textures.tests
|
|||
{ component-order R32G32B32 }
|
||||
{ bitmap B{ } }
|
||||
} power-of-2-image
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ { 0 0 } { 10 0 } }
|
||||
{ { 0 20 } { 10 20 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
{ { 10 20 } { 30 20 } }
|
||||
{ { 10 30 } { 30 300 } }
|
||||
}
|
||||
[ [ image new swap >>dim ] map ] map image-locs
|
||||
] unit-test
|
||||
|
|
@ -1,16 +1,15 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs cache colors.constants destructors fry kernel
|
||||
opengl opengl.gl combinators images grouping specialized-arrays.float
|
||||
locals sequences math math.vectors generalizations ;
|
||||
opengl opengl.gl combinators images images.tesselation grouping
|
||||
specialized-arrays.float locals sequences math math.vectors
|
||||
math.matrices generalizations fry columns ;
|
||||
IN: opengl.textures
|
||||
|
||||
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
|
||||
|
||||
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
|
||||
|
||||
TUPLE: texture loc dim texture-coords texture display-list disposed ;
|
||||
|
||||
GENERIC: component-order>format ( component-order -- format type )
|
||||
|
||||
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
|
||||
|
|
@ -19,8 +18,14 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
|
|||
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
|
||||
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
||||
|
||||
GENERIC: draw-texture ( texture -- )
|
||||
|
||||
GENERIC: draw-scaled-texture ( dim texture -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
|
||||
|
||||
: repeat-last ( seq n -- seq' )
|
||||
over peek pad-tail concat ;
|
||||
|
||||
|
|
@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
|||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
|
||||
|
||||
: draw-textured-rect ( dim texture -- )
|
||||
: with-texturing ( quot -- )
|
||||
GL_TEXTURE_2D [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_COORD_ARRAY [
|
||||
COLOR: white gl-color
|
||||
dup loc>> [
|
||||
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
|
||||
[ init-texture texture-coords>> gl-texture-coord-pointer ] bi
|
||||
fill-rect-vertices (gl-fill-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-translation
|
||||
call
|
||||
] do-enabled-client-state
|
||||
] do-attribs
|
||||
] do-enabled ;
|
||||
] do-enabled ; inline
|
||||
|
||||
: (draw-textured-rect) ( dim texture -- )
|
||||
[ loc>> ]
|
||||
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
|
||||
[ init-texture texture-coords>> gl-texture-coord-pointer ] tri
|
||||
swap gl-fill-rect ;
|
||||
|
||||
: draw-textured-rect ( dim texture -- )
|
||||
[
|
||||
(draw-textured-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-texturing ;
|
||||
|
||||
: texture-coords ( dim -- coords )
|
||||
[ dup next-power-of-2 /f ] map
|
||||
|
|
@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
|||
: make-texture-display-list ( texture -- dlist )
|
||||
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
texture new swap >>loc
|
||||
: <single-texture> ( image loc -- texture )
|
||||
single-texture new swap >>loc
|
||||
swap
|
||||
[ dim>> >>dim ] keep
|
||||
[ dim>> product 0 = ] keep '[
|
||||
|
|
@ -105,12 +115,59 @@ PRIVATE>
|
|||
dup make-texture-display-list >>display-list
|
||||
] unless ;
|
||||
|
||||
M: texture dispose*
|
||||
M: single-texture dispose*
|
||||
[ texture>> [ delete-texture ] when* ]
|
||||
[ display-list>> [ delete-dlist ] when* ] bi ;
|
||||
|
||||
: draw-texture ( texture -- )
|
||||
display-list>> [ glCallList ] when* ;
|
||||
M: single-texture draw-texture display-list>> [ glCallList ] when* ;
|
||||
|
||||
: draw-scaled-texture ( dim texture -- )
|
||||
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
|
||||
M: single-texture draw-scaled-texture
|
||||
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
|
||||
|
||||
TUPLE: multi-texture grid display-list loc disposed ;
|
||||
|
||||
: image-locs ( image-grid -- loc-grid )
|
||||
[ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
|
||||
[ 0 [ + ] accumulate nip ] bi@
|
||||
cross-zip flip ;
|
||||
|
||||
: <texture-grid> ( image-grid loc -- grid )
|
||||
[ dup image-locs ] dip
|
||||
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
|
||||
|
||||
: draw-textured-grid ( grid -- )
|
||||
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
|
||||
|
||||
: make-textured-grid-display-list ( grid -- dlist )
|
||||
GL_COMPILE [
|
||||
[
|
||||
[
|
||||
[
|
||||
[ dim>> ] keep (draw-textured-rect)
|
||||
] each
|
||||
] each
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-texturing
|
||||
] make-dlist ;
|
||||
|
||||
: <multi-texture> ( image-grid loc -- multi-texture )
|
||||
[
|
||||
[
|
||||
<texture-grid> dup
|
||||
make-textured-grid-display-list
|
||||
] keep
|
||||
f multi-texture boa
|
||||
] with-destructors ;
|
||||
|
||||
M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
|
||||
|
||||
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
|
||||
|
||||
CONSTANT: max-texture-size { 256 256 }
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
over dim>> max-texture-size [ <= ] 2all?
|
||||
[ <single-texture> ]
|
||||
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
USING: kernel tools.test peg peg.ebnf words math math.parser
|
||||
sequences accessors peg.parsers parser namespaces arrays
|
||||
strings eval ;
|
||||
strings eval unicode.data multiline ;
|
||||
IN: peg.ebnf.tests
|
||||
|
||||
{ T{ ebnf-non-terminal f "abc" } } [
|
||||
|
|
@ -520,3 +520,13 @@ Tok = Spaces (Number | Special )
|
|||
{ "\\" } [
|
||||
"\\" [EBNF foo="\\" EBNF]
|
||||
] unit-test
|
||||
|
||||
[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
|
||||
|
||||
[ <" USE: peg.ebnf [EBNF
|
||||
lol = a
|
||||
lol = b
|
||||
EBNF] "> eval
|
||||
] [
|
||||
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
|
||||
] must-fail-with
|
||||
|
|
|
|||
|
|
@ -5,13 +5,18 @@ 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 summary ;
|
||||
IN: peg.ebnf
|
||||
|
||||
: rule ( name word -- parser )
|
||||
#! Given an EBNF word produced from EBNF: return the EBNF rule
|
||||
"ebnf-parser" word-prop at ;
|
||||
|
||||
ERROR: no-rule rule parser ;
|
||||
|
||||
: lookup-rule ( rule parser -- rule' )
|
||||
2dup rule [ 2nip ] [ no-rule ] if* ;
|
||||
|
||||
TUPLE: tokenizer any one many ;
|
||||
|
||||
: default-tokenizer ( -- tokenizer )
|
||||
|
|
@ -34,8 +39,13 @@ TUPLE: tokenizer any one many ;
|
|||
: reset-tokenizer ( -- )
|
||||
default-tokenizer \ tokenizer set-global ;
|
||||
|
||||
ERROR: no-tokenizer name ;
|
||||
|
||||
M: no-tokenizer summary
|
||||
drop "Tokenizer not found" ;
|
||||
|
||||
SYNTAX: TOKENIZER:
|
||||
scan search [ "Tokenizer not found" throw ] unless*
|
||||
scan dup search [ nip ] [ no-tokenizer ] if*
|
||||
execute( -- tokenizer ) \ tokenizer set-global ;
|
||||
|
||||
TUPLE: ebnf-non-terminal symbol ;
|
||||
|
|
@ -258,7 +268,7 @@ DEFER: 'choice'
|
|||
"]]" token ensure-not ,
|
||||
"]?" token ensure-not ,
|
||||
[ drop t ] satisfy ,
|
||||
] seq* [ first ] action repeat0 [ >string ] action ;
|
||||
] seq* repeat0 [ concat >string ] action ;
|
||||
|
||||
: 'ensure-not' ( -- parser )
|
||||
#! Parses the '!' syntax to ensure that
|
||||
|
|
@ -367,15 +377,16 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
|
|||
(transform)
|
||||
dup parser-tokenizer \ tokenizer set-global
|
||||
] if ;
|
||||
|
||||
ERROR: redefined-rule name ;
|
||||
|
||||
M: redefined-rule summary
|
||||
name>> "Rule '" "' defined more than once" surround ;
|
||||
|
||||
M: ebnf-rule (transform) ( ast -- parser )
|
||||
dup elements>>
|
||||
(transform) [
|
||||
swap symbol>> dup get parser? [
|
||||
"Rule '" over append "' defined more than once" append throw
|
||||
] [
|
||||
set
|
||||
] if
|
||||
swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
|
||||
] keep ;
|
||||
|
||||
M: ebnf-sequence (transform) ( ast -- parser )
|
||||
|
|
@ -466,14 +477,18 @@ ERROR: bad-effect quot effect ;
|
|||
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
|
||||
[ bad-effect ]
|
||||
} cond ;
|
||||
|
||||
: ebnf-transform ( ast -- parser quot )
|
||||
[ parser>> (transform) ]
|
||||
[ code>> insert-escapes ]
|
||||
[ parser>> ] tri build-locals
|
||||
[ string-lines parse-lines ] call( string -- quot ) ;
|
||||
|
||||
M: ebnf-action (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
|
||||
[ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
|
||||
ebnf-transform check-action-effect action ;
|
||||
|
||||
M: ebnf-semantic (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
|
||||
[ string-lines parse-lines ] call( string -- quot ) semantic ;
|
||||
ebnf-transform semantic ;
|
||||
|
||||
M: ebnf-var (transform) ( ast -- parser )
|
||||
parser>> (transform) ;
|
||||
|
|
@ -481,19 +496,20 @@ M: ebnf-var (transform) ( ast -- parser )
|
|||
M: ebnf-terminal (transform) ( ast -- parser )
|
||||
symbol>> tokenizer one>> call( symbol -- parser ) ;
|
||||
|
||||
ERROR: ebnf-foreign-not-found name ;
|
||||
|
||||
M: ebnf-foreign-not-found summary
|
||||
name>> "Foreign word '" "' not found" surround ;
|
||||
|
||||
M: ebnf-foreign (transform) ( ast -- parser )
|
||||
dup word>> search
|
||||
[ "Foreign word '" swap word>> append "' not found" append throw ] unless*
|
||||
dup word>> search [ word>> ebnf-foreign-not-found ] unless*
|
||||
swap rule>> [ main ] unless* over rule [
|
||||
nip
|
||||
] [
|
||||
execute( -- parser )
|
||||
] if* ;
|
||||
|
||||
: parser-not-found ( name -- * )
|
||||
[
|
||||
"Parser '" % % "' not found." %
|
||||
] "" make throw ;
|
||||
ERROR: parser-not-found name ;
|
||||
|
||||
M: ebnf-non-terminal (transform) ( ast -- parser )
|
||||
symbol>> [
|
||||
|
|
@ -504,16 +520,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
|
|||
'ebnf' parse transform ;
|
||||
|
||||
: check-parse-result ( result -- result )
|
||||
dup [
|
||||
dup remaining>> [ blank? ] trim empty? [
|
||||
[
|
||||
dup remaining>> [ blank? ] trim [
|
||||
[
|
||||
"Unable to fully parse EBNF. Left to parse was: " %
|
||||
remaining>> %
|
||||
] "" make throw
|
||||
] unless
|
||||
] unless-empty
|
||||
] [
|
||||
"Could not parse EBNF" throw
|
||||
] if ;
|
||||
] if* ;
|
||||
|
||||
: parse-ebnf ( string -- hashtable )
|
||||
'ebnf' (parse) check-parse-result ast>> transform ;
|
||||
|
|
@ -522,14 +538,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
|
|||
parse-ebnf dup dup parser [ main swap at compile ] with-variable
|
||||
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
|
||||
|
||||
SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at
|
||||
SYNTAX: <EBNF
|
||||
"EBNF>"
|
||||
reset-tokenizer parse-multiline-string parse-ebnf main swap at
|
||||
parsed reset-tokenizer ;
|
||||
|
||||
SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip
|
||||
SYNTAX: [EBNF
|
||||
"EBNF]"
|
||||
reset-tokenizer parse-multiline-string ebnf>quot nip
|
||||
parsed \ call parsed reset-tokenizer ;
|
||||
|
||||
SYNTAX: EBNF:
|
||||
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
|
||||
ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop
|
||||
ebnf>quot swapd
|
||||
(( input -- ast )) define-declared "ebnf-parser" set-word-prop
|
||||
reset-tokenizer ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test quoting ;
|
||||
IN: quoting.tests
|
||||
|
||||
[ f ] [ "" quoted? ] unit-test
|
||||
[ t ] [ "''" quoted? ] unit-test
|
||||
[ t ] [ "\"\"" quoted? ] unit-test
|
||||
[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
|
||||
[ t ] [ "'Circus Maximus'" quoted? ] unit-test
|
||||
[ f ] [ "Circus Maximus" quoted? ] unit-test
|
||||
|
|
@ -84,21 +84,24 @@ C: <box> box
|
|||
{ } assoc-like [ first integer? ] partition
|
||||
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
|
||||
|
||||
:: step ( last-match index str quot final? direction -- last-index/f )
|
||||
: advance ( index backwards? -- index+/-1 )
|
||||
-1 1 ? + >fixnum ; inline
|
||||
|
||||
: check ( index string backwards? -- in-bounds? )
|
||||
[ drop -1 eq? not ] [ length < ] if ; inline
|
||||
|
||||
:: step ( last-match index str quot final? backwards? -- last-index/f )
|
||||
final? index last-match ?
|
||||
index str bounds-check? [
|
||||
index direction + str
|
||||
index str backwards? check [
|
||||
index backwards? advance str
|
||||
index str nth-unsafe
|
||||
quot call
|
||||
] when ; inline
|
||||
|
||||
: direction ( -- n )
|
||||
backwards? get -1 1 ? ;
|
||||
|
||||
: transitions>quot ( transitions final-state? -- quot )
|
||||
dup shortest? get and [ 2drop [ drop nip ] ] [
|
||||
[ split-literals swap case>quot ] dip direction
|
||||
'[ { array-capacity string } declare _ _ _ step ]
|
||||
[ split-literals swap case>quot ] dip backwards? get
|
||||
'[ { fixnum string } declare _ _ _ step ]
|
||||
] if ;
|
||||
|
||||
: word>quot ( word dfa -- quot )
|
||||
|
|
@ -122,10 +125,13 @@ C: <box> box
|
|||
: dfa>main-word ( dfa -- word )
|
||||
states>words [ states>code ] keep start-state>> ;
|
||||
|
||||
: word-template ( quot -- quot' )
|
||||
'[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: dfa>word ( dfa -- quot )
|
||||
dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
|
||||
dfa>main-word execution-quot word-template
|
||||
(( start-index string regexp -- i/f )) define-temp ;
|
||||
|
||||
: dfa>shortest-word ( dfa -- word )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel math ;
|
||||
USING: help.markup help.syntax kernel math strings ;
|
||||
IN: roman
|
||||
|
||||
HELP: >roman
|
||||
|
|
@ -39,7 +39,7 @@ HELP: roman>
|
|||
{ >roman >ROMAN roman> } related-words
|
||||
|
||||
HELP: roman+
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Adds two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -49,7 +49,7 @@ HELP: roman+
|
|||
} ;
|
||||
|
||||
HELP: roman-
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Subtracts two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -61,7 +61,7 @@ HELP: roman-
|
|||
{ roman+ roman- } related-words
|
||||
|
||||
HELP: roman*
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Multiplies two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -71,7 +71,7 @@ HELP: roman*
|
|||
} ;
|
||||
|
||||
HELP: roman/i
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Computes the integer division of two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -81,7 +81,7 @@ HELP: roman/i
|
|||
} ;
|
||||
|
||||
HELP: roman/mod
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Computes the quotient and remainder of two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel io roman ;"
|
||||
|
|
|
|||
|
|
@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
|
|||
[ "iii" "iii" roman- ] must-fail
|
||||
|
||||
[ 30 ] [ ROMAN: xxx ] unit-test
|
||||
|
||||
[ roman+ ] must-infer
|
||||
[ roman- ] must-infer
|
||||
[ roman* ] must-infer
|
||||
[ roman/i ] must-infer
|
||||
[ roman/mod ] must-infer
|
||||
|
|
|
|||
|
|
@ -1,29 +1,33 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel math math.order math.vectors
|
||||
namespaces make quotations sequences splitting.monotonic
|
||||
sequences.private strings unicode.case lexer parser
|
||||
grouping ;
|
||||
USING: accessors arrays assocs fry generalizations grouping
|
||||
kernel lexer macros make math math.order math.vectors
|
||||
namespaces parser quotations sequences sequences.private
|
||||
splitting.monotonic stack-checker strings unicode.case
|
||||
words effects ;
|
||||
IN: roman
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: roman-digits ( -- seq )
|
||||
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
|
||||
CONSTANT: roman-digits
|
||||
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
|
||||
|
||||
: roman-values ( -- seq )
|
||||
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
|
||||
CONSTANT: roman-values
|
||||
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
|
||||
|
||||
ERROR: roman-range-error n ;
|
||||
|
||||
: roman-range-check ( n -- )
|
||||
dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
|
||||
|
||||
: roman-digit-index ( ch -- n )
|
||||
1string roman-digits index ; inline
|
||||
|
||||
: roman<= ( ch1 ch2 -- ? )
|
||||
[ 1string roman-digits index ] bi@ >= ;
|
||||
[ roman-digit-index ] bi@ >= ;
|
||||
|
||||
: roman>n ( ch -- n )
|
||||
1string roman-digits index roman-values nth ;
|
||||
roman-digit-index roman-values nth ;
|
||||
|
||||
: (>roman) ( n -- )
|
||||
roman-values roman-digits [
|
||||
|
|
@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
|
|||
] 2each drop ;
|
||||
|
||||
: (roman>) ( seq -- n )
|
||||
[ [ roman>n ] map ] [ all-eq? ] bi [
|
||||
sum
|
||||
] [
|
||||
first2 swap -
|
||||
] if ;
|
||||
[ [ roman>n ] map ] [ all-eq? ] bi
|
||||
[ sum ] [ first2 swap - ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >roman ( n -- str )
|
||||
dup roman-range-check
|
||||
[ (>roman) ] "" make ;
|
||||
dup roman-range-check [ (>roman) ] "" make ;
|
||||
|
||||
: >ROMAN ( n -- str ) >roman >upper ;
|
||||
|
||||
: roman> ( str -- n )
|
||||
>lower [ roman<= ] monotonic-split
|
||||
[ (roman>) ] sigma ;
|
||||
>lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 2roman> ( str1 str2 -- m n )
|
||||
[ roman> ] bi@ ;
|
||||
|
||||
: binary-roman-op ( str1 str2 quot -- str3 )
|
||||
[ 2roman> ] dip call >roman ; inline
|
||||
MACRO: binary-roman-op ( quot -- quot' )
|
||||
[ infer in>> ] [ ] [ infer out>> ] tri
|
||||
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: roman+ ( str1 str2 -- str3 )
|
||||
[ + ] binary-roman-op ;
|
||||
<<
|
||||
SYNTAX: ROMAN-OP:
|
||||
scan-word [ name>> "roman" prepend create-in ] keep
|
||||
1quotation '[ _ binary-roman-op ]
|
||||
dup infer [ in>> ] [ out>> ] bi
|
||||
[ "string" <repetition> ] bi@ <effect> define-declared ;
|
||||
>>
|
||||
|
||||
: roman- ( str1 str2 -- str3 )
|
||||
[ - ] binary-roman-op ;
|
||||
|
||||
: roman* ( str1 str2 -- str3 )
|
||||
[ * ] binary-roman-op ;
|
||||
|
||||
: roman/i ( str1 str2 -- str3 )
|
||||
[ /i ] binary-roman-op ;
|
||||
|
||||
: roman/mod ( str1 str2 -- str3 str4 )
|
||||
[ /mod ] binary-roman-op [ >roman ] dip ;
|
||||
ROMAN-OP: +
|
||||
ROMAN-OP: -
|
||||
ROMAN-OP: *
|
||||
ROMAN-OP: /i
|
||||
ROMAN-OP: /mod
|
||||
|
||||
SYNTAX: ROMAN: scan roman> parsed ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: sorting.human
|
|||
|
||||
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
|
||||
|
||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
|
||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
|
||||
|
||||
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
IN: specialized-vectors.tests
|
||||
USING: specialized-vectors.double tools.test kernel sequences ;
|
||||
USING: specialized-arrays.float
|
||||
specialized-vectors.float
|
||||
specialized-vectors.double
|
||||
tools.test kernel sequences ;
|
||||
|
||||
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
|
||||
|
||||
[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test
|
||||
|
|
@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
|
|||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Index search
|
||||
\ index [
|
||||
dup sequence? [
|
||||
dup length 4 >= [
|
||||
dup length zip >hashtable '[ _ at ]
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Shuffling
|
||||
: nths-quot ( indices -- quot )
|
||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||
|
|
|
|||
|
|
@ -35,9 +35,9 @@ HELP: download-feed
|
|||
{ $values { "url" url } { "feed" feed } }
|
||||
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
|
||||
|
||||
HELP: string>feed
|
||||
{ $values { "string" string } { "feed" feed } }
|
||||
{ $description "Parses a feed in string form." } ;
|
||||
HELP: parse-feed
|
||||
{ $values { "seq" "a string or a byte array" } { "feed" feed } }
|
||||
{ $description "Parses a feed." } ;
|
||||
|
||||
HELP: xml>feed
|
||||
{ $values { "xml" xml } { "feed" feed } }
|
||||
|
|
@ -58,7 +58,7 @@ $nl
|
|||
{ $subsection <entry> }
|
||||
"Reading feeds:"
|
||||
{ $subsection download-feed }
|
||||
{ $subsection string>feed }
|
||||
{ $subsection parse-feed }
|
||||
{ $subsection xml>feed }
|
||||
"Writing feeds:"
|
||||
{ $subsection feed>xml }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: syndication io kernel io.files tools.test io.encodings.utf8
|
||||
USING: syndication io kernel io.files tools.test io.encodings.binary
|
||||
calendar urls xml.writer ;
|
||||
IN: syndication.tests
|
||||
|
||||
|
|
@ -8,7 +8,7 @@ IN: syndication.tests
|
|||
: load-news-file ( filename -- feed )
|
||||
#! Load an news syndication file and process it, returning
|
||||
#! it as an feed tuple.
|
||||
utf8 file-contents string>feed ;
|
||||
binary file-contents parse-feed ;
|
||||
|
||||
[ T{
|
||||
feed
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
||||
! Portions copyright (C) 2008 Slava Pestov.
|
||||
! Portions copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.traversal kernel assocs math.order
|
||||
strings sequences xml.data xml.writer
|
||||
io.streams.string combinators xml xml.entities.html io.files io
|
||||
http.client namespaces make xml.syntax hashtables
|
||||
calendar.format accessors continuations urls present ;
|
||||
USING: xml.traversal kernel assocs math.order strings sequences
|
||||
xml.data xml.writer io.streams.string combinators xml
|
||||
xml.entities.html io.files io http.client namespaces make
|
||||
xml.syntax hashtables calendar.format accessors continuations
|
||||
urls present byte-arrays ;
|
||||
IN: syndication
|
||||
|
||||
: any-tag-named ( tag names -- tag-inside )
|
||||
|
|
@ -106,12 +106,15 @@ TUPLE: entry title url description date ;
|
|||
{ "feed" [ atom1.0 ] }
|
||||
} case ;
|
||||
|
||||
: string>feed ( string -- feed )
|
||||
[ string>xml xml>feed ] with-html-entities ;
|
||||
GENERIC: parse-feed ( seq -- feed )
|
||||
|
||||
M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
|
||||
|
||||
M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
|
||||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get nip string>feed ;
|
||||
http-get nip parse-feed ;
|
||||
|
||||
! Atom generation
|
||||
|
||||
|
|
|
|||
|
|
@ -157,6 +157,7 @@ IN: tools.deploy.shaker
|
|||
"specializer"
|
||||
"step-into"
|
||||
"step-into?"
|
||||
"superclass"
|
||||
"transform-n"
|
||||
"transform-quot"
|
||||
"tuple-dispatch-generic"
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ HELP: scaffold-undocumented
|
|||
HELP: scaffold-vocab
|
||||
{ $values
|
||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
|
||||
|
||||
HELP: scaffold-emacs
|
||||
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test tools.scaffold unicode.case kernel
|
||||
multiline tools.scaffold.private io.streams.string ;
|
||||
IN: tools.scaffold.tests
|
||||
|
||||
: undocumented-word ( obj1 obj2 -- obj3 obj4 )
|
||||
[ >lower ] [ >upper ] bi* ;
|
||||
|
||||
[
|
||||
<" HELP: undocumented-word
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object }
|
||||
{ "obj3" object } { "obj4" object }
|
||||
}
|
||||
{ $description "" } ;
|
||||
">
|
||||
]
|
||||
[
|
||||
[ \ undocumented-word (help.) ] with-string-writer
|
||||
] unit-test
|
||||
|
|
@ -134,7 +134,7 @@ ERROR: no-vocab vocab ;
|
|||
vocabulary>> using get [ conjoin ] [ drop ] if* ;
|
||||
|
||||
: ($values.) ( array -- )
|
||||
[
|
||||
[ bl ] [
|
||||
"{ " write
|
||||
dup array? [ first ] when
|
||||
dup lookup-type [
|
||||
|
|
@ -145,7 +145,7 @@ ERROR: no-vocab vocab ;
|
|||
null add-using
|
||||
] if
|
||||
" }" write
|
||||
] each ;
|
||||
] interleave ;
|
||||
|
||||
: 4bl ( -- )
|
||||
" " write ; inline
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
|
|||
COLOR: red gl-color
|
||||
[ dim>> ] [ >label< line-metrics ] bi
|
||||
[ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
|
||||
[ drop gl-rect ]
|
||||
[ drop { 0 0 } swap gl-rect ]
|
||||
2bi ;
|
||||
|
||||
: <metrics-gadget> ( text font -- gadget )
|
||||
|
|
|
|||
|
|
@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
|
|||
|
||||
:: draw-selection ( line pair editor -- )
|
||||
pair [ editor font>> line offset>x ] map :> pair
|
||||
pair first 0 2array [
|
||||
editor selection-color>> gl-color
|
||||
pair second pair first - round 1 max
|
||||
editor line-height 2array gl-fill-rect
|
||||
] with-translation ;
|
||||
editor selection-color>> gl-color
|
||||
pair first 0 2array
|
||||
pair second pair first - round 1 max editor line-height 2array
|
||||
gl-fill-rect ;
|
||||
|
||||
: draw-unselected-line ( line editor -- )
|
||||
font>> swap draw-text ;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
|
|||
ui.gadgets.debug sequences ;
|
||||
IN: ui.gadgets.grids.tests
|
||||
|
||||
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
|
||||
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
|
||||
|
||||
: 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.order namespaces make sequences words io
|
||||
USING: arrays kernel math math.order math.matrices namespaces make sequences words io
|
||||
math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
|
||||
math.rectangles fry ;
|
||||
IN: ui.gadgets.grids
|
||||
|
|
@ -33,9 +33,6 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||
[ [ 2array ] with map ] curry map ;
|
||||
|
||||
TUPLE: cell pref-dim baseline cap-height ;
|
||||
|
||||
: <cell> ( gadget -- cell )
|
||||
|
|
@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
|
|||
|
||||
M: grid children-on ( rect gadget -- seq )
|
||||
dup children>> empty? [ 2drop f ] [
|
||||
{ 0 1 } swap grid>>
|
||||
[ { 0 1 } ] dip grid>>
|
||||
[ 0 <column> fast-children-on ] keep
|
||||
<slice> concat
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
|
|||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
rect-bounds gl-fill-rect
|
||||
] if-fits ;
|
||||
|
||||
M: node draw-selection ( loc node -- )
|
||||
|
|
|
|||
|
|
@ -121,16 +121,15 @@ M: table layout*
|
|||
[ [ line-height ] dip * 0 swap 2array ]
|
||||
[ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
|
||||
|
||||
: highlight-row ( table row color quot -- )
|
||||
[ [ row-rect rect-bounds ] dip gl-color ] dip
|
||||
'[ _ @ ] with-translation ; inline
|
||||
: row-bounds ( table row -- loc dim )
|
||||
row-rect rect-bounds ; inline
|
||||
|
||||
: draw-selected-row ( table -- )
|
||||
{
|
||||
{ [ dup selected-index>> not ] [ drop ] }
|
||||
[
|
||||
[ ] [ selected-index>> ] [ selection-color>> ] tri
|
||||
[ gl-fill-rect ] highlight-row
|
||||
[ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
|
||||
row-bounds gl-fill-rect
|
||||
]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -139,14 +138,15 @@ M: table layout*
|
|||
{ [ dup focused?>> not ] [ drop ] }
|
||||
{ [ dup selected-index>> not ] [ drop ] }
|
||||
[
|
||||
[ ] [ selected-index>> ] [ focus-border-color>> ] tri
|
||||
[ gl-rect ] highlight-row
|
||||
[ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
|
||||
row-bounds gl-rect
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: draw-moused-row ( table -- )
|
||||
dup mouse-index>> dup [
|
||||
over mouse-color>> [ gl-rect ] highlight-row
|
||||
over mouse-color>> gl-color
|
||||
row-bounds gl-rect
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: column-line-offsets ( table -- xs )
|
||||
|
|
@ -279,7 +279,7 @@ PRIVATE>
|
|||
|
||||
: row-action ( table -- )
|
||||
dup selected-row
|
||||
[ swap [ action>> call ] [ dup hook>> call ] bi ]
|
||||
[ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
|
|||
|
||||
M: solid recompute-pen
|
||||
swap dim>>
|
||||
[ (fill-rect-vertices) >>interior-vertices ]
|
||||
[ (rect-vertices) >>boundary-vertices ]
|
||||
[ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
|
||||
[ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
|
||||
bi drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ SYMBOL: viewport-translation
|
|||
! white gl-clear is broken w.r.t window resizing
|
||||
! Linux/PPC Radeon 9200
|
||||
COLOR: white gl-color
|
||||
clip get dim>> gl-fill-rect ;
|
||||
{ 0 0 } clip get dim>> gl-fill-rect ;
|
||||
|
||||
GENERIC: draw-gadget* ( gadget -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
|
|||
IN: ui.tools.browser
|
||||
|
||||
ARTICLE: "ui-browser" "UI browser"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
|
||||
{ $subsection com-browse }
|
||||
{ $subsection browser-window }
|
||||
{ $command-map browser-gadget "toolbar" }
|
||||
|
|
|
|||
|
|
@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
|
|||
|
||||
: listener-run-files ( seq -- )
|
||||
[
|
||||
[ \ listener-run-files ] dip
|
||||
'[ _ [ run-file ] each ] call-listener
|
||||
'[ _ [ run-file ] each ]
|
||||
\ listener-run-files
|
||||
call-listener
|
||||
] unless-empty ;
|
||||
|
||||
: com-end ( listener -- )
|
||||
|
|
|
|||
|
|
@ -81,8 +81,6 @@ IN: ui.tools.operations
|
|||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
UNION: definition word method-spec link vocab vocab-link ;
|
||||
|
||||
[ definition? ] \ edit H{
|
||||
{ +keyboard+ T{ key-down f { C+ } "e" } }
|
||||
{ +listener+ t }
|
||||
|
|
|
|||
|
|
@ -9,6 +9,9 @@ IN: unicode.breaks.tests
|
|||
[ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
|
||||
dup last-grapheme head last-grapheme ] unit-test
|
||||
|
||||
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
|
||||
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
|
||||
|
||||
: grapheme-break-test ( -- filename )
|
||||
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ SYMBOL: table
|
|||
: finish-table ( -- table )
|
||||
table get [ [ 1 = ] map ] map ;
|
||||
|
||||
: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
|
||||
: eval-seq ( seq -- seq ) [ ?execute ] map ;
|
||||
|
||||
: (set-table) ( class1 class2 val -- )
|
||||
[ table get nth ] dip '[ _ or ] change-nth ;
|
||||
|
|
@ -101,6 +101,16 @@ PRIVATE>
|
|||
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
|
||||
nip swap length or 1+ ;
|
||||
|
||||
: first-grapheme-from ( start str -- i )
|
||||
over tail-slice first-grapheme + ;
|
||||
|
||||
: last-grapheme ( str -- i )
|
||||
unclip-last-slice grapheme-class swap
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
|
||||
|
||||
: last-grapheme-from ( end str -- i )
|
||||
swap head-slice last-grapheme ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >pieces ( str quot: ( str -- i ) -- graphemes )
|
||||
|
|
@ -114,10 +124,6 @@ PRIVATE>
|
|||
: string-reverse ( str -- rts )
|
||||
>graphemes reverse concat ;
|
||||
|
||||
: last-grapheme ( str -- i )
|
||||
unclip-last-slice grapheme-class swap
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
graphemes init-table table
|
||||
|
|
|
|||
|
|
@ -18,4 +18,12 @@ kernel io.streams.string xml.writer ;
|
|||
<" int x = "hi";
|
||||
/* a comment */ "> <string-reader> htmlize-stream
|
||||
write-xml
|
||||
] unit-test
|
||||
|
||||
[ "<span class=\"MARKUP\">: foo</span> <span class=\"MARKUP\">;</span>" ] [
|
||||
{ ": foo ;" } "factor" htmlize-lines xml>string
|
||||
] unit-test
|
||||
|
||||
[ ":foo" ] [
|
||||
{ ":foo" } "factor" htmlize-lines xml>string
|
||||
] unit-test
|
||||
|
|
@ -84,7 +84,7 @@ M: string-matcher text-matches?
|
|||
] keep string>> length and ;
|
||||
|
||||
M: regexp text-matches?
|
||||
[ >string ] dip re-contains? ;
|
||||
[ >string ] dip first-match dup [ to>> ] when ;
|
||||
|
||||
: rule-start-matches? ( rule -- match-count/f )
|
||||
dup start>> tuck swap can-match-here? [
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
USING: kernel sequences namespaces assocs graphs math math.order ;
|
||||
IN: definitions
|
||||
|
||||
MIXIN: definition
|
||||
|
||||
ERROR: no-compilation-unit definition ;
|
||||
|
||||
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ ERROR: bad-effect ;
|
|||
scan {
|
||||
{ "(" [ ")" parse-effect ] }
|
||||
{ f [ ")" unexpected-eof ] }
|
||||
[ bad-effect ]
|
||||
} case 2array
|
||||
] when
|
||||
] if
|
||||
|
|
@ -31,4 +32,4 @@ ERROR: bad-effect ;
|
|||
"(" expect ")" parse-effect ;
|
||||
|
||||
: parse-call( ( accum word -- accum )
|
||||
[ ")" parse-effect ] dip 2array over push-all ;
|
||||
[ ")" parse-effect ] dip 2array over push-all ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors words kernel sequences namespaces make assocs
|
||||
hashtables definitions kernel.private classes classes.private
|
||||
|
|
@ -27,6 +27,8 @@ M: generic definition drop f ;
|
|||
PREDICATE: method-spec < pair
|
||||
first2 generic? swap class? and ;
|
||||
|
||||
INSTANCE: method-spec definition
|
||||
|
||||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ TUPLE: hashtable
|
|||
: grow-hash ( hash -- )
|
||||
[ [ >alist ] [ assoc-size 1+ ] bi ] keep
|
||||
[ reset-hash ] keep
|
||||
swap (rehash) ; inline
|
||||
swap (rehash) ;
|
||||
|
||||
: ?grow-hash ( hash -- )
|
||||
dup hash-large? [
|
||||
|
|
@ -95,7 +95,7 @@ TUPLE: hashtable
|
|||
PRIVATE>
|
||||
|
||||
: <hashtable> ( n -- hash )
|
||||
hashtable new [ reset-hash ] keep ;
|
||||
hashtable new [ reset-hash ] keep ; inline
|
||||
|
||||
M: hashtable at* ( key hash -- value ? )
|
||||
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||
|
|
|
|||
|
|
@ -15,11 +15,10 @@ SLOT: i
|
|||
[ 1+ ] change-i drop ; inline
|
||||
|
||||
: sequence-read1 ( stream -- elt/f )
|
||||
[ >sequence-stream< ?nth ]
|
||||
[ next ] bi ; inline
|
||||
[ >sequence-stream< ?nth ] [ next ] bi ; inline
|
||||
|
||||
: add-length ( n stream -- i+n )
|
||||
[ i>> + ] [ underlying>> length ] bi min ; inline
|
||||
[ i>> + ] [ underlying>> length ] bi min ; inline
|
||||
|
||||
: (sequence-read) ( n stream -- seq/f )
|
||||
[ add-length ] keep
|
||||
|
|
@ -32,8 +31,8 @@ SLOT: i
|
|||
[ (sequence-read) ] [ 2drop f ] if ; inline
|
||||
|
||||
: find-sep ( seps stream -- sep/f n )
|
||||
swap [ >sequence-stream< ] dip
|
||||
[ memq? ] curry find-from swap ; inline
|
||||
swap [ >sequence-stream< swap tail-slice ] dip
|
||||
[ memq? ] curry find swap ; inline
|
||||
|
||||
: sequence-read-until ( separators stream -- seq sep/f )
|
||||
[ find-sep ] keep
|
||||
|
|
|
|||
|
|
@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
|
|||
|
||||
GENERIC: execute ( word -- )
|
||||
|
||||
GENERIC: ?execute ( word -- value )
|
||||
|
||||
M: object ?execute ;
|
||||
|
||||
DEFER: if
|
||||
|
||||
: ? ( ? true false -- true/false )
|
||||
|
|
|
|||
|
|
@ -30,6 +30,6 @@ PRIVATE>
|
|||
: bind ( ns quot -- ) swap >n call ndrop ; inline
|
||||
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
|
||||
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
|
||||
: with-scope ( quot -- ) H{ } clone swap bind ; inline
|
||||
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
|
||||
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
|
||||
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
|
||||
|
|
@ -556,18 +556,18 @@ HELP: BIN:
|
|||
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
|
||||
|
||||
HELP: GENERIC:
|
||||
{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
|
||||
{ $syntax "GENERIC: word ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
|
||||
|
||||
HELP: GENERIC#
|
||||
{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
|
||||
{ $syntax "GENERIC# word n ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
|
||||
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
|
||||
{ $notes
|
||||
"The following two definitions are equivalent:"
|
||||
{ $code "GENERIC: foo" }
|
||||
{ $code "GENERIC# foo 0" }
|
||||
{ $code "GENERIC: foo ( obj -- )" }
|
||||
{ $code "GENERIC# foo 0 ( obj -- )" }
|
||||
} ;
|
||||
|
||||
HELP: MATH:
|
||||
|
|
@ -576,7 +576,7 @@ HELP: MATH:
|
|||
{ $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
|
||||
|
||||
HELP: HOOK:
|
||||
{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
|
||||
{ $syntax "HOOK: word variable ( stack -- effect ) " }
|
||||
{ $values { "word" "a new word to define" } { "variable" word } }
|
||||
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"CONSTANT:" [
|
||||
CREATE scan-object define-constant
|
||||
CREATE-WORD scan-object define-constant
|
||||
] define-core-syntax
|
||||
|
||||
":" [
|
||||
|
|
|
|||
|
|
@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
|
|||
: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
|
||||
|
||||
PREDICATE: runnable-vocab < vocab
|
||||
vocab-main >boolean ;
|
||||
vocab-main >boolean ;
|
||||
|
||||
INSTANCE: vocab-spec definition
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: math eval tools.test effects ;
|
||||
IN: words.alias.tests
|
||||
|
||||
ALIAS: foo +
|
||||
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
|
||||
[ (( -- value )) ] [ \ foo stack-effect ] unit-test
|
||||
|
|
@ -12,6 +12,8 @@ IN: words
|
|||
|
||||
M: word execute (execute) ;
|
||||
|
||||
M: word ?execute execute( -- value ) ;
|
||||
|
||||
M: word <=>
|
||||
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
|
||||
|
||||
|
|
@ -260,3 +262,5 @@ M: word hashcode*
|
|||
M: word literalize <wrapper> ;
|
||||
|
||||
: xref-words ( -- ) all-words [ xref ] each ;
|
||||
|
||||
INSTANCE: word definition
|
||||
|
|
@ -59,11 +59,11 @@ C: <transaction> transaction
|
|||
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
] if ; inline recursive
|
||||
|
||||
: process-to-date ( account date -- account )
|
||||
over interest-last-paid>> 1 days time+
|
||||
[ dupd process-day ] spin each-day ;
|
||||
[ dupd process-day ] spin each-day ; inline
|
||||
|
||||
: inserting-transactions ( account transactions -- account )
|
||||
[ [ date>> process-to-date ] keep >>transaction ] each ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays kernel math namespaces
|
||||
opengl.gl sequences math.vectors ui images images.viewer
|
||||
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
|
||||
opengl.gl sequences math.vectors ui images images.normalization
|
||||
images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
|
||||
IN: cap
|
||||
|
||||
: screenshot-array ( world -- byte-array )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
IN: game-input.tests
|
||||
USING: game-input tools.test kernel system threads ;
|
||||
USING: ui game-input tools.test kernel system threads
|
||||
combinators.short-circuit calendar ;
|
||||
|
||||
os windows? os macosx? or [
|
||||
{
|
||||
[ os windows? ui-running? and ]
|
||||
[ os macosx? ]
|
||||
} 0|| [
|
||||
[ ] [ open-game-input ] unit-test
|
||||
[ ] [ yield ] unit-test
|
||||
[ ] [ 1 seconds sleep ] unit-test
|
||||
[ ] [ close-game-input ] unit-test
|
||||
] when
|
||||
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays html.parser.utils hashtables io kernel
|
||||
namespaces make prettyprint quotations sequences splitting
|
||||
html.parser.state strings unicode.categories unicode.case ;
|
||||
USING: accessors arrays hashtables html.parser.state
|
||||
html.parser.utils kernel make namespaces sequences
|
||||
unicode.case unicode.categories combinators.short-circuit
|
||||
quoting ;
|
||||
IN: html.parser
|
||||
|
||||
|
||||
TUPLE: tag name attributes text closing? ;
|
||||
|
||||
SINGLETON: text
|
||||
|
|
@ -28,116 +30,103 @@ SYMBOL: tagstack
|
|||
: make-tag ( string attribs -- tag )
|
||||
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
|
||||
|
||||
: make-text-tag ( string -- tag )
|
||||
: new-tag ( string type -- tag )
|
||||
tag new
|
||||
text >>name
|
||||
swap >>text ;
|
||||
swap >>name
|
||||
swap >>text ; inline
|
||||
|
||||
: make-comment-tag ( string -- tag )
|
||||
tag new
|
||||
comment >>name
|
||||
swap >>text ;
|
||||
: make-text-tag ( string -- tag ) text new-tag ; inline
|
||||
|
||||
: make-dtd-tag ( string -- tag )
|
||||
tag new
|
||||
dtd >>name
|
||||
swap >>text ;
|
||||
: make-comment-tag ( string -- tag ) comment new-tag ; inline
|
||||
|
||||
: read-whitespace ( -- string )
|
||||
[ get-char blank? not ] take-until ;
|
||||
: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
|
||||
|
||||
: read-whitespace* ( -- ) read-whitespace drop ;
|
||||
: read-single-quote ( state-parser -- string )
|
||||
[ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
|
||||
|
||||
: read-token ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char blank? ] take-until ;
|
||||
: read-double-quote ( state-parser -- string )
|
||||
[ [ CHAR: " = ] take-until ] [ next drop ] bi ;
|
||||
|
||||
: read-single-quote ( -- string )
|
||||
[ get-char CHAR: ' = ] take-until ;
|
||||
: read-quote ( state-parser -- string )
|
||||
dup get+increment CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if ;
|
||||
|
||||
: read-double-quote ( -- string )
|
||||
[ get-char CHAR: " = ] take-until ;
|
||||
: read-key ( state-parser -- string )
|
||||
skip-whitespace
|
||||
[ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
||||
|
||||
: read-quote ( -- string )
|
||||
get-char next CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if next ;
|
||||
: read-= ( state-parser -- )
|
||||
skip-whitespace
|
||||
[ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
|
||||
|
||||
: read-key ( -- string )
|
||||
read-whitespace*
|
||||
[ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
|
||||
: read-token ( state-parser -- string )
|
||||
[ blank? ] take-until ;
|
||||
|
||||
: read-= ( -- )
|
||||
read-whitespace*
|
||||
[ get-char CHAR: = = ] take-until drop next ;
|
||||
|
||||
: read-value ( -- string )
|
||||
read-whitespace*
|
||||
get-char quote? [ read-quote ] [ read-token ] if
|
||||
: read-value ( state-parser -- string )
|
||||
skip-whitespace
|
||||
dup get-char quote? [ read-quote ] [ read-token ] if
|
||||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( -- )
|
||||
"-->" take-string make-comment-tag push-tag ;
|
||||
: read-comment ( state-parser -- )
|
||||
"-->" take-until-sequence make-comment-tag push-tag ;
|
||||
|
||||
: read-dtd ( -- )
|
||||
">" take-string make-dtd-tag push-tag ;
|
||||
: read-dtd ( state-parser -- )
|
||||
">" take-until-sequence make-dtd-tag push-tag ;
|
||||
|
||||
: read-bang ( -- )
|
||||
next get-char CHAR: - = get-next CHAR: - = and [
|
||||
: read-bang ( state-parser -- )
|
||||
next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
|
||||
next next
|
||||
read-comment
|
||||
] [
|
||||
read-dtd
|
||||
] if ;
|
||||
|
||||
: read-tag ( -- string )
|
||||
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
|
||||
get-char CHAR: < = [ next ] unless ;
|
||||
: read-tag ( state-parser -- string )
|
||||
[ [ "><" member? ] take-until ]
|
||||
[ dup get-char CHAR: < = [ next ] unless drop ] bi ;
|
||||
|
||||
: read-< ( -- string )
|
||||
next get-char CHAR: ! = [
|
||||
read-bang f
|
||||
: read-until-< ( state-parser -- string )
|
||||
[ CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( state-parser -- )
|
||||
read-until-< [ make-text-tag push-tag ] unless-empty ;
|
||||
|
||||
: (parse-attributes) ( state-parser -- )
|
||||
skip-whitespace
|
||||
dup state-parse-end? [
|
||||
drop
|
||||
] [
|
||||
read-tag
|
||||
[
|
||||
[ read-key >lower ] [ read-= ] [ read-value ] tri
|
||||
2array ,
|
||||
] keep (parse-attributes)
|
||||
] if ;
|
||||
|
||||
: read-until-< ( -- string )
|
||||
[ get-char CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( -- )
|
||||
read-until-< [
|
||||
make-text-tag push-tag
|
||||
] unless-empty ;
|
||||
|
||||
: (parse-attributes) ( -- )
|
||||
read-whitespace*
|
||||
string-parse-end? [
|
||||
read-key >lower read-= read-value
|
||||
2array , (parse-attributes)
|
||||
] unless ;
|
||||
|
||||
: parse-attributes ( -- hashtable )
|
||||
: parse-attributes ( state-parser -- hashtable )
|
||||
[ (parse-attributes) ] { } make >hashtable ;
|
||||
|
||||
: (parse-tag) ( string -- string' hashtable )
|
||||
[
|
||||
read-token >lower
|
||||
parse-attributes
|
||||
] string-parse ;
|
||||
[ read-token >lower ] [ parse-attributes ] bi
|
||||
] state-parse ;
|
||||
|
||||
: parse-tag ( -- )
|
||||
read-< [
|
||||
(parse-tag) make-tag push-tag
|
||||
] unless-empty ;
|
||||
: read-< ( state-parser -- string/f )
|
||||
next dup get-char [
|
||||
CHAR: ! = [ read-bang f ] [ read-tag ] if
|
||||
] [
|
||||
drop f
|
||||
] if* ;
|
||||
|
||||
: (parse-html) ( -- )
|
||||
get-next [
|
||||
parse-text
|
||||
parse-tag
|
||||
(parse-html)
|
||||
] when ;
|
||||
: parse-tag ( state-parser -- )
|
||||
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
|
||||
|
||||
: (parse-html) ( state-parser -- )
|
||||
dup get-next [
|
||||
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
|
||||
] [ drop ] if ;
|
||||
|
||||
: tag-parse ( quot -- vector )
|
||||
V{ } clone tagstack [ string-parse ] with-variable ; inline
|
||||
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
||||
|
||||
: parse-html ( string -- vector )
|
||||
[ (parse-html) tagstack get ] tag-parse ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,36 @@
|
|||
USING: tools.test html.parser.state ascii kernel ;
|
||||
USING: tools.test html.parser.state ascii kernel accessors ;
|
||||
IN: html.parser.state.tests
|
||||
|
||||
: take-rest ( -- string )
|
||||
[ f ] take-until ;
|
||||
[ "hello" ]
|
||||
[ "hello" [ take-rest ] state-parse ] unit-test
|
||||
|
||||
: take-char ( -- string )
|
||||
[ get-char = ] curry take-until ;
|
||||
[ "hi" " how are you?" ]
|
||||
[
|
||||
"hi how are you?"
|
||||
[ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ "foo" ";bar" ]
|
||||
[
|
||||
"foo;bar" [
|
||||
[ CHAR: ; take-until-object ] [ take-rest ] bi
|
||||
] state-parse
|
||||
] unit-test
|
||||
|
||||
[ "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 and bar" [
|
||||
[ "and" take-until-sequence ] [ take-rest ] bi
|
||||
] state-parse
|
||||
] unit-test
|
||||
|
||||
[ 6 ]
|
||||
[
|
||||
" foo " [ skip-whitespace n>> ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,41 +1,67 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math kernel sequences accessors fry circular ;
|
||||
USING: namespaces math kernel sequences accessors fry circular
|
||||
unicode.case unicode.categories locals ;
|
||||
|
||||
IN: html.parser.state
|
||||
|
||||
TUPLE: state string i ;
|
||||
TUPLE: state-parser sequence n ;
|
||||
|
||||
: get-i ( -- i ) state get i>> ; inline
|
||||
: <state-parser> ( sequence -- state-parser )
|
||||
state-parser new
|
||||
swap >>sequence
|
||||
0 >>n ;
|
||||
|
||||
: get-char ( -- char )
|
||||
state get [ i>> ] [ string>> ] bi ?nth ; inline
|
||||
: (get-char) ( n state -- char/f )
|
||||
sequence>> ?nth ; inline
|
||||
|
||||
: get-next ( -- char )
|
||||
state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
|
||||
: get-char ( state -- char/f )
|
||||
[ n>> ] keep (get-char) ; inline
|
||||
|
||||
: next ( -- )
|
||||
state get [ 1+ ] change-i drop ; inline
|
||||
: get-next ( state -- char/f )
|
||||
[ n>> 1 + ] keep (get-char) ; inline
|
||||
|
||||
: string-parse ( string quot -- )
|
||||
[ 0 state boa state ] dip with-variable ; inline
|
||||
: next ( state -- state )
|
||||
[ 1 + ] change-n ; inline
|
||||
|
||||
: short* ( n seq -- n' seq )
|
||||
over [ nip dup length swap ] unless ; inline
|
||||
: get+increment ( state -- char/f )
|
||||
[ get-char ] [ next drop ] bi ; inline
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap
|
||||
[ drop ] [ next skip-until ] if
|
||||
] [ drop ] if ; inline recursive
|
||||
: state-parse ( sequence quot -- )
|
||||
[ <state-parser> ] dip call ; inline
|
||||
|
||||
: take-until ( quot: ( -- ? ) -- )
|
||||
get-i [ skip-until ] dip get-i
|
||||
state get string>> subseq ; inline
|
||||
:: skip-until ( state quot: ( obj -- ? ) -- )
|
||||
state get-char [
|
||||
quot call [ state next quot skip-until ] unless
|
||||
] when* ; inline recursive
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-growing-circular sequence= ; inline
|
||||
: state-parse-end? ( state -- ? ) get-next not ;
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <growing-circular>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
dup length rot length 1- - head next ; inline
|
||||
: take-until ( state quot: ( obj -- ? ) -- sequence/f )
|
||||
over state-parse-end? [
|
||||
2drop f
|
||||
] [
|
||||
[ drop n>> ]
|
||||
[ skip-until ]
|
||||
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
|
||||
] if ; inline
|
||||
|
||||
:: take-until-sequence ( state-parser sequence -- sequence' )
|
||||
sequence length <growing-circular> :> growing
|
||||
state-parser
|
||||
[
|
||||
growing push-growing-circular
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
found dup length
|
||||
growing length 1- - head
|
||||
state-parser next drop ;
|
||||
|
||||
: skip-whitespace ( state -- state )
|
||||
[ [ blank? not ] take-until drop ] keep ;
|
||||
|
||||
: take-rest ( state -- sequence )
|
||||
[ drop f ] take-until ; inline
|
||||
|
||||
: take-until-object ( state obj -- sequence )
|
||||
'[ _ = ] take-until ;
|
||||
|
|
|
|||
|
|
@ -1,20 +1,13 @@
|
|||
USING: assocs combinators continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
strings tools.test ;
|
||||
USING: html.parser.utils ;
|
||||
strings tools.test html.parser.utils quoting ;
|
||||
IN: html.parser.utils.tests
|
||||
|
||||
[ "'Rome'" ] [ "Rome" single-quote ] unit-test
|
||||
[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
|
||||
[ "'Firenze'" ] [ "Firenze" quote ] unit-test
|
||||
[ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test
|
||||
[ f ] [ "" quoted? ] unit-test
|
||||
[ t ] [ "''" quoted? ] unit-test
|
||||
[ t ] [ "\"\"" quoted? ] unit-test
|
||||
[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
|
||||
[ t ] [ "'Circus Maximus'" quoted? ] unit-test
|
||||
[ f ] [ "Circus Maximus" quoted? ] unit-test
|
||||
[ "'Italy'" ] [ "Italy" ?quote ] unit-test
|
||||
[ "'Italy'" ] [ "'Italy'" ?quote ] unit-test
|
||||
[ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,16 +3,12 @@
|
|||
USING: assocs circular combinators continuations hashtables
|
||||
hashtables.private io kernel math namespaces prettyprint
|
||||
quotations sequences splitting html.parser.state strings
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit quoting ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: string-parse-end? ( -- ? ) get-next not ;
|
||||
|
||||
: trim1 ( seq ch -- newseq )
|
||||
[ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
|
||||
|
||||
: quote? ( ch -- ? ) "'\"" member? ;
|
||||
|
||||
: single-quote ( str -- newstr ) "'" dup surround ;
|
||||
|
||||
: double-quote ( str -- newstr ) "\"" dup surround ;
|
||||
|
|
@ -21,14 +17,4 @@ IN: html.parser.utils
|
|||
CHAR: ' over member?
|
||||
[ double-quote ] [ single-quote ] if ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
{
|
||||
[ length 1 > ]
|
||||
[ first quote? ]
|
||||
[ [ first ] [ peek ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
|
||||
|
||||
: unquote ( str -- newstr )
|
||||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||
|
|
|
|||
|
|
@ -1,23 +1,113 @@
|
|||
! Copyright (C) 2008 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax sequences kernel accessors ;
|
||||
USING: help.markup help.syntax sequences kernel accessors
|
||||
id3.private strings ;
|
||||
IN: id3
|
||||
|
||||
HELP: file-id3-tags
|
||||
HELP: mp3>id3
|
||||
{ $values
|
||||
{ "path" "a path string" }
|
||||
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
|
||||
$nl { $link title>> }
|
||||
$nl { $link artist>> }
|
||||
$nl { $link album>> }
|
||||
$nl { $link year>> }
|
||||
$nl { $link genre>> }
|
||||
$nl { $link comment>> } } ;
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
|
||||
{ $list
|
||||
{ $link title }
|
||||
{ $link artist }
|
||||
{ $link album }
|
||||
{ $link year }
|
||||
{ $link genre }
|
||||
{ $link comment }
|
||||
}
|
||||
"For other fields, use the " { $link find-id3-frame } " word."
|
||||
} ;
|
||||
|
||||
HELP: album
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "album/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: artist
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "artist/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: comment
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "comment/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: genre
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "genre/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: title
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "title/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: year
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "year/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: find-id3-frame
|
||||
{ $values
|
||||
{ "id3" id3v2-info } { "name" string }
|
||||
{ "obj/f" "object or f" }
|
||||
}
|
||||
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
|
||||
|
||||
HELP: mp3-paths>id3s
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "From a sequence of pathnames, parses each ID3 header and returns a sequence of key/value pairs of pathnames and ID3 objects." } ;
|
||||
|
||||
HELP: find-mp3s
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Returns a sequence of MP3 pathnames from a directory and all of its subdirectories." } ;
|
||||
|
||||
HELP: parse-mp3-directory
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Returns a sequence of key/value pairs where the key is the path of an MP3 and the value is the parsed ID3 header or " { $link f } " recursively for each MP3 file in the directory and all subdirectories." } ;
|
||||
|
||||
ARTICLE: "id3" "ID3 tags"
|
||||
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
|
||||
"Parsing ID3 tags from an MP3 file:"
|
||||
{ $subsection file-id3-tags } ;
|
||||
"Parsing ID3 tags for a directory of MP3s, recursively:"
|
||||
{ $subsection parse-mp3-directory }
|
||||
"Finding MP3 files recursively:"
|
||||
{ $subsection find-mp3s }
|
||||
"Parsing a sequence of MP3 pathnames:"
|
||||
{ $subsection mp3-paths>id3s }
|
||||
"Parsing an MP3 file's ID3 tags:"
|
||||
{ $subsection mp3>id3 }
|
||||
"ID3v1 frame tag accessors:"
|
||||
{ $subsection album }
|
||||
{ $subsection artist }
|
||||
{ $subsection comment }
|
||||
{ $subsection genre }
|
||||
{ $subsection title }
|
||||
{ $subsection year }
|
||||
"Access any frame tag:"
|
||||
{ $subsection find-id3-frame } ;
|
||||
|
||||
ABOUT: "id3"
|
||||
|
|
|
|||
|
|
@ -5,12 +5,12 @@ IN: id3.tests
|
|||
|
||||
: id3-params ( id3 -- title artist album year comment genre )
|
||||
{
|
||||
[ id3-title ]
|
||||
[ id3-artist ]
|
||||
[ id3-album ]
|
||||
[ id3-year ]
|
||||
[ id3-comment ]
|
||||
[ id3-genre ]
|
||||
[ title ]
|
||||
[ artist ]
|
||||
[ album ]
|
||||
[ year ]
|
||||
[ comment ]
|
||||
[ genre ]
|
||||
} cleave ;
|
||||
|
||||
[
|
||||
|
|
@ -20,7 +20,7 @@ IN: id3.tests
|
|||
"2009"
|
||||
"COMMENT"
|
||||
"Bluegrass"
|
||||
] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
[
|
||||
"Anthem of the Trinity"
|
||||
|
|
@ -29,7 +29,7 @@ IN: id3.tests
|
|||
f
|
||||
f
|
||||
"Classical"
|
||||
] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
[
|
||||
"Stormy Weather"
|
||||
|
|
@ -38,5 +38,5 @@ IN: id3.tests
|
|||
f
|
||||
"eng, AG# 08E1C12E"
|
||||
"Big Band"
|
||||
] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -48,15 +48,14 @@ TUPLE: id3v2-info header frames ;
|
|||
|
||||
TUPLE: id3v1-info title artist album year comment genre ;
|
||||
|
||||
: <id3v1-info> ( -- object ) id3v1-info new ;
|
||||
: <id3v1-info> ( -- object ) id3v1-info new ; inline
|
||||
|
||||
: <id3v2-info> ( header frames -- object )
|
||||
[ [ frame-id>> ] keep ] H{ } map>assoc
|
||||
id3v2-info boa ;
|
||||
[ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
|
||||
|
||||
: <header> ( -- object ) header new ;
|
||||
: <header> ( -- object ) header new ; inline
|
||||
|
||||
: <frame> ( -- object ) frame new ;
|
||||
: <frame> ( -- object ) frame new ; inline
|
||||
|
||||
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
|
||||
|
||||
|
|
@ -66,7 +65,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
: id3v1-frame ( string key -- frame )
|
||||
<frame>
|
||||
swap >>frame-id
|
||||
swap >>data ;
|
||||
swap >>data ; inline
|
||||
|
||||
: id3v1>id3v2 ( id3v1 -- id3v2 )
|
||||
[
|
||||
|
|
@ -78,7 +77,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ comment>> "COMM" id3v1-frame ]
|
||||
[ genre>> "TCON" id3v1-frame ]
|
||||
} cleave
|
||||
] output>array f swap <id3v2-info> ;
|
||||
] output>array f swap <id3v2-info> ; inline
|
||||
|
||||
: >28bitword ( seq -- int )
|
||||
0 [ [ 7 shift ] dip bitor ] reduce ; inline
|
||||
|
|
@ -104,11 +103,11 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ [ 4 8 ] dip subseq >28bitword >>size ]
|
||||
[ [ 8 10 ] dip subseq >byte-array >>flags ]
|
||||
[ read-frame-data decode-text >>data ]
|
||||
} cleave ;
|
||||
} cleave ; inline
|
||||
|
||||
: read-frame ( mmap -- frame/f )
|
||||
dup 4 head-slice valid-frame-id?
|
||||
[ (read-frame) ] [ drop f ] if ;
|
||||
[ (read-frame) ] [ drop f ] if ; inline
|
||||
|
||||
: remove-frame ( mmap frame -- mmap )
|
||||
size>> 10 + tail-slice ; inline
|
||||
|
|
@ -116,10 +115,8 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
: read-frames ( mmap -- frames )
|
||||
[ dup read-frame dup ]
|
||||
[ [ remove-frame ] keep ]
|
||||
produce 2nip ;
|
||||
produce 2nip ; inline
|
||||
|
||||
! header stuff
|
||||
|
||||
: read-v2-header ( seq -- id3header )
|
||||
[ <header> ] dip
|
||||
{
|
||||
|
|
@ -133,8 +130,6 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ read-v2-header ]
|
||||
[ read-frames ] bi* <id3v2-info> ; inline
|
||||
|
||||
! v1 information
|
||||
|
||||
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
|
||||
|
||||
: (read-v1-tag-data) ( seq -- mp3-file )
|
||||
|
|
@ -159,28 +154,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
drop
|
||||
] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: frame-named ( id3 name quot -- obj )
|
||||
[ swap frames>> at* ] dip
|
||||
[ data>> ] prepose [ drop f ] if ; inline
|
||||
|
||||
: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
|
||||
|
||||
: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
|
||||
|
||||
: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
|
||||
|
||||
: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
|
||||
|
||||
: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
|
||||
|
||||
: id3-genre ( id3 -- genre/f )
|
||||
"TCON" [ parse-genre ] frame-named ; inline
|
||||
|
||||
: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
|
||||
|
||||
: (file-id3-tags) ( path -- id3v2-info/f )
|
||||
: (mp3>id3) ( path -- id3v2-info/f )
|
||||
[
|
||||
{
|
||||
{ [ dup id3v2? ] [ read-v2-tag-data ] }
|
||||
|
|
@ -189,9 +163,36 @@ PRIVATE>
|
|||
} cond
|
||||
] with-mapped-uchar-file ;
|
||||
|
||||
: file-id3-tags ( path -- id3v2-info/f )
|
||||
dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ;
|
||||
: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
|
||||
[ swap frames>> at* ] dip
|
||||
[ data>> ] prepose [ drop f ] if ; inline
|
||||
|
||||
: parse-id3s ( path -- seq )
|
||||
[ >lower ".mp3" tail? ] find-all-files
|
||||
[ dup file-id3-tags ] { } map>assoc ;
|
||||
PRIVATE>
|
||||
|
||||
: mp3>id3 ( path -- id3v2-info/f )
|
||||
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
|
||||
|
||||
: find-id3-frame ( id3 name -- obj/f )
|
||||
[ ] (find-id3-frame) ; inline
|
||||
|
||||
: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
|
||||
|
||||
: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
|
||||
|
||||
: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
|
||||
|
||||
: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
|
||||
|
||||
: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
|
||||
|
||||
: genre ( id3 -- genre/f )
|
||||
"TCON" [ parse-genre ] (find-id3-frame) ; inline
|
||||
|
||||
: find-mp3s ( path -- seq )
|
||||
[ >lower ".mp3" tail? ] find-all-files ; inline
|
||||
|
||||
: mp3-paths>id3s ( seq -- seq' )
|
||||
[ dup mp3>id3 ] { } map>assoc ; inline
|
||||
|
||||
: parse-mp3-directory ( path -- seq )
|
||||
find-mp3s mp3-paths>id3s ;
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
|
|||
" hostname servername :irc.factor" irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call drop ;
|
||||
irc> connect>> call drop ; inline
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
"JOIN " irc-write
|
||||
|
|
|
|||
|
|
@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
|
|||
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
|
||||
|
||||
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
|
||||
|
||||
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
|
||||
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.order math.vectors sequences ;
|
||||
IN: math.matrices
|
||||
|
|
@ -57,3 +57,6 @@ PRIVATE>
|
|||
|
||||
: norm-gram-schmidt ( seq -- orthonormal )
|
||||
gram-schmidt [ normalize ] map ;
|
||||
|
||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||
[ [ 2array ] with map ] curry map ;
|
||||
|
|
@ -16,11 +16,6 @@ HELP: run-spider
|
|||
{ "spider" spider } }
|
||||
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
|
||||
|
||||
HELP: slurp-heap-while
|
||||
{ $values
|
||||
{ "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
|
||||
{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
|
||||
|
||||
ARTICLE: "spider-tutorial" "Spider tutorial"
|
||||
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
|
||||
{ $code <" "http://concatenative.org" <spider> "> }
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: accessors fry html.parser html.parser.analyzer
|
||||
http.client kernel tools.time sets assocs sequences
|
||||
concurrency.combinators io threads namespaces math multiline
|
||||
heaps math.parser inspector urls assoc-heaps logging
|
||||
combinators.short-circuit continuations calendar prettyprint ;
|
||||
math.parser inspector urls logging combinators.short-circuit
|
||||
continuations calendar prettyprint dlists deques locals ;
|
||||
IN: spider
|
||||
|
||||
TUPLE: spider base count max-count sleep max-depth initial-links
|
||||
|
|
@ -13,12 +13,33 @@ filters spidered todo nonmatching quiet ;
|
|||
TUPLE: spider-result url depth headers fetch-time parsed-html
|
||||
links processing-time timestamp ;
|
||||
|
||||
TUPLE: todo-url url depth ;
|
||||
|
||||
: <todo-url> ( url depth -- todo-url )
|
||||
todo-url new
|
||||
swap >>depth
|
||||
swap >>url ;
|
||||
|
||||
TUPLE: unique-deque assoc deque ;
|
||||
|
||||
: <unique-deque> ( -- unique-deque )
|
||||
H{ } clone <dlist> unique-deque boa ;
|
||||
|
||||
: push-url ( url depth unique-deque -- )
|
||||
[ <todo-url> ] dip
|
||||
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
|
||||
[ deque>> push-back ] 2bi ;
|
||||
|
||||
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
|
||||
|
||||
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
|
||||
|
||||
: <spider> ( base -- spider )
|
||||
>url
|
||||
spider new
|
||||
over >>base
|
||||
swap 0 <unique-min-heap> [ heap-push ] keep >>todo
|
||||
<unique-min-heap> >>nonmatching
|
||||
swap 0 <unique-deque> [ push-url ] keep >>todo
|
||||
<unique-deque> >>nonmatching
|
||||
0 >>max-depth
|
||||
0 >>count
|
||||
1/0. >>max-count
|
||||
|
|
@ -27,10 +48,10 @@ links processing-time timestamp ;
|
|||
<PRIVATE
|
||||
|
||||
: apply-filters ( links spider -- links' )
|
||||
filters>> [ '[ _ 1&& ] filter ] when* ;
|
||||
filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
|
||||
|
||||
: push-links ( links level assoc-heap -- )
|
||||
'[ _ _ heap-push ] each ;
|
||||
: push-links ( links level unique-deque -- )
|
||||
'[ _ _ push-url ] each ;
|
||||
|
||||
: add-todo ( links level spider -- )
|
||||
todo>> push-links ;
|
||||
|
|
@ -38,64 +59,72 @@ links processing-time timestamp ;
|
|||
: add-nonmatching ( links level spider -- )
|
||||
nonmatching>> push-links ;
|
||||
|
||||
: filter-base ( spider spider-result -- base-links nonmatching-links )
|
||||
: filter-base-links ( spider spider-result -- base-links nonmatching-links )
|
||||
[ base>> host>> ] [ links>> prune ] bi*
|
||||
[ host>> = ] with partition ;
|
||||
|
||||
: add-spidered ( spider spider-result -- )
|
||||
[ [ 1+ ] change-count ] dip
|
||||
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
|
||||
[ filter-base ] 2keep
|
||||
[ filter-base-links ] 2keep
|
||||
depth>> 1+ swap
|
||||
[ add-nonmatching ]
|
||||
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
|
||||
|
||||
: normalize-hrefs ( links -- links' )
|
||||
[ >url ] map
|
||||
spider get base>> swap [ derive-url ] with map ;
|
||||
: normalize-hrefs ( links spider -- links' )
|
||||
[ [ >url ] map ] dip
|
||||
base>> swap [ derive-url ] with map ;
|
||||
|
||||
: print-spidering ( url depth -- )
|
||||
"depth: " write number>string write
|
||||
", spidering: " write . yield ;
|
||||
|
||||
: (spider-page) ( url depth -- spider-result )
|
||||
f pick spider get spidered>> set-at
|
||||
over '[ _ http-get ] benchmark swap
|
||||
[ parse-html dup find-hrefs normalize-hrefs ] benchmark
|
||||
:: new-spidered-result ( spider url depth -- spider-result )
|
||||
f url spider spidered>> set-at
|
||||
[ url http-get ] benchmark :> fetch-time :> html :> headers
|
||||
[
|
||||
html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
|
||||
] benchmark :> processing-time :> links :> parsed-html
|
||||
url depth headers fetch-time parsed-html links processing-time
|
||||
now spider-result boa ;
|
||||
|
||||
: spider-page ( url depth -- )
|
||||
spider get quiet>> [ 2dup print-spidering ] unless
|
||||
(spider-page)
|
||||
spider get [ quiet>> [ dup describe ] unless ]
|
||||
[ swap add-spidered ] bi ;
|
||||
:: spider-page ( spider url depth -- )
|
||||
spider quiet>> [ url depth print-spidering ] unless
|
||||
spider url depth new-spidered-result :> spidered-result
|
||||
spider quiet>> [ spidered-result describe ] unless
|
||||
spider spidered-result add-spidered ;
|
||||
|
||||
\ spider-page ERROR add-error-logging
|
||||
|
||||
: spider-sleep ( -- )
|
||||
spider get sleep>> [ sleep ] when* ;
|
||||
: spider-sleep ( spider -- )
|
||||
sleep>> [ sleep ] when* ;
|
||||
|
||||
: queue-initial-links ( spider -- spider )
|
||||
[ initial-links>> normalize-hrefs 0 ] keep
|
||||
[ add-todo ] keep ;
|
||||
:: queue-initial-links ( spider -- spider )
|
||||
spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
|
||||
|
||||
: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
|
||||
pick heap-empty? [ 3drop ] [
|
||||
[ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
|
||||
[ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
|
||||
] if ; inline recursive
|
||||
: spider-page? ( spider -- ? )
|
||||
{
|
||||
[ todo>> deque>> deque-empty? not ]
|
||||
[ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
|
||||
[ [ count>> ] [ max-count>> ] bi < ]
|
||||
} 1&& ;
|
||||
|
||||
: setup-next-url ( spider -- spider url depth )
|
||||
dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
|
||||
|
||||
: spider-next-page ( spider -- )
|
||||
setup-next-url spider-page ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: run-spider-loop ( spider -- )
|
||||
dup spider-page? [
|
||||
[ spider-next-page ] [ run-spider-loop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: run-spider ( spider -- spider )
|
||||
"spider" [
|
||||
dup spider [
|
||||
queue-initial-links
|
||||
[ todo>> ] [ max-depth>> ] bi
|
||||
'[
|
||||
_ <= spider get
|
||||
[ count>> ] [ max-count>> ] bi < and
|
||||
] [ spider-page spider-sleep ] slurp-heap-while
|
||||
spider get
|
||||
] with-variable
|
||||
queue-initial-links [ run-spider-loop ] keep
|
||||
] with-logging ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: tetris.gl
|
|||
#! OpenGL rendering for tetris
|
||||
|
||||
: draw-block ( block -- )
|
||||
[ { 1 1 } gl-fill-rect ] with-translation ;
|
||||
{ 1 1 } gl-fill-rect ;
|
||||
|
||||
: draw-piece-blocks ( piece -- )
|
||||
piece-blocks [ draw-block ] each ;
|
||||
|
|
|
|||
|
|
@ -57,9 +57,7 @@ M: list draw-gadget*
|
|||
origin get [
|
||||
dup color>> gl-color
|
||||
selected-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
rect-bounds gl-fill-rect
|
||||
] when*
|
||||
] with-translation ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
</t:a>
|
||||
</h2>
|
||||
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
<t:farkup t:name="content" />
|
||||
</t:bind>
|
||||
</div>
|
||||
</td>
|
||||
|
|
@ -58,7 +58,7 @@
|
|||
<tr>
|
||||
<td colspan="2" class="footer">
|
||||
<t:bind t:name="footer">
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
<t:farkup t:name="content" />
|
||||
</t:bind>
|
||||
</td>
|
||||
</tr>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
include vm/Config.linux
|
||||
include vm/Config.x86.64
|
||||
LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue