Fix conflict
commit
3045777f02
14
README.txt
14
README.txt
|
@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
|
|||
|
||||
* Running Factor on Windows XP/Vista
|
||||
|
||||
The Factor runtime is compiled into two binaries:
|
||||
|
||||
factor.com - a Windows console application
|
||||
factor.exe - a Windows native application, without a console
|
||||
|
||||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt:
|
||||
the command prompt using the console application:
|
||||
|
||||
factor.exe -i=boot.<cpu>.image
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor.exe -run=listener
|
||||
factor.com -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry ;
|
||||
accessors combinators effects continuations fry call ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
@ -258,7 +258,7 @@ M: long-long-type box-return ( type -- )
|
|||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> { } swap with-datastack first
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
|
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call kernel ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences generalizations accessors
|
||||
continuations effects.parser parser ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call(
|
||||
")" parse-effect parsed \ call-effect parsed ; parsing
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math
|
|||
namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private parser lexer init core-foundation fry
|
||||
generalizations specialized-arrays.direct.alien ;
|
||||
generalizations specialized-arrays.direct.alien call ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
@ -83,7 +83,7 @@ class-init-hooks global [ H{ } clone or ] change-at
|
|||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
drop over class-init-hooks get at [ assert-depth ] when*
|
||||
drop over class-init-hooks get at [ call( -- ) ] when*
|
||||
2dup execute dup [ 2nip ] [
|
||||
2drop "No such class: " prepend throw
|
||||
] if
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
@ -181,8 +181,9 @@ SYMBOL: history
|
|||
"custom-inlining" word-prop ;
|
||||
|
||||
: inline-custom ( #call word -- ? )
|
||||
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
|
||||
first object swap eliminate-dispatch ;
|
||||
[ dup ] [ "custom-inlining" word-prop ] bi*
|
||||
call( #call -- word/quot/f )
|
||||
object swap eliminate-dispatch ;
|
||||
|
||||
: inline-instance-check ( #call word -- ? )
|
||||
over in-d>> second value-info literal>> dup class?
|
||||
|
|
|
@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger
|
|||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep ;
|
||||
sequences.deep call ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
|
@ -15,9 +15,9 @@ SYMBOL: vocabs-quot
|
|||
: check-example ( element -- )
|
||||
[
|
||||
rest [
|
||||
but-last "\n" join 1vector
|
||||
[ (eval>string) ] with-datastack
|
||||
peek "\n" ?tail drop
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call ;
|
||||
|
@ -145,7 +145,7 @@ M: help-error error.
|
|||
bi ;
|
||||
|
||||
: check-something ( obj quot -- )
|
||||
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
|
||||
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
|
||||
|
||||
: check-word ( word -- )
|
||||
[ with-file-vocabs ] vocabs-quot set
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging continuations
|
||||
logging call
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
|
@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ;
|
|||
template-cache get clear-assoc ;
|
||||
|
||||
M: chloe call-template*
|
||||
template-quot assert-depth ;
|
||||
template-quot call( -- ) ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax continuations ;
|
||||
xml.writer xml.data xml.entities html.forms call
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
|
@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: compile-chloe-tag ( tag -- )
|
||||
dup main>> dup tags get at
|
||||
[ curry assert-depth ]
|
||||
[ curry call( -- ) ]
|
||||
[ unknown-chloe-tag ]
|
||||
?if ;
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
assocs fry vocabs.parser parser lexer io io.files call
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
@ -72,6 +72,6 @@ TUPLE: fhtml path ;
|
|||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[ _ path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
'[ _ path>> utf8 file-contents eval-template ] call( -- ) ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
|
@ -87,11 +87,16 @@ ERROR: invalid-file-size n ;
|
|||
: handle>file-size ( handle -- n )
|
||||
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
|
||||
|
||||
ERROR: seek-before-start n ;
|
||||
|
||||
: set-seek-ptr ( n handle -- )
|
||||
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
|
||||
|
||||
M: winnt seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ seek-absolute [ (>>ptr) ] }
|
||||
{ seek-relative [ [ + ] change-ptr drop ] }
|
||||
{ seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] }
|
||||
{ seek-absolute [ set-seek-ptr ] }
|
||||
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
|
||||
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
|
||||
[ bad-seek-type ]
|
||||
} case ;
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyback (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math ;
|
||||
USING: kernel accessors math lists ;
|
||||
QUALIFIED: sequences
|
||||
IN: persistent.deques
|
||||
|
||||
|
@ -9,25 +9,23 @@ IN: persistent.deques
|
|||
! same source, it could take O(m) amortized time per update.
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: cons { car read-only } { cdr read-only } ;
|
||||
C: <cons> cons
|
||||
|
||||
: each ( list quot: ( elt -- ) -- )
|
||||
over
|
||||
[ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ]
|
||||
[ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ]
|
||||
[ 2drop ] if ; inline recursive
|
||||
|
||||
: reduce ( list start quot -- end )
|
||||
swapd each ; inline
|
||||
|
||||
: reverse ( list -- reversed )
|
||||
f [ swap <cons> ] reduce ;
|
||||
f [ swap cons ] reduce ;
|
||||
|
||||
: length ( list -- length )
|
||||
0 [ drop 1+ ] reduce ;
|
||||
|
||||
: cut ( list index -- back front-reversed )
|
||||
f swap [ [ [ cdr>> ] [ car>> ] bi ] dip <cons> ] times ;
|
||||
f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ;
|
||||
|
||||
: split-reverse ( list -- back-reversed front )
|
||||
dup length 2/ cut [ reverse ] bi@ ;
|
||||
|
@ -49,7 +47,7 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
: push ( item deque -- newdeque )
|
||||
[ front>> <cons> ] [ back>> ] bi deque boa ; inline
|
||||
[ front>> cons ] [ back>> ] bi deque boa ; inline
|
||||
PRIVATE>
|
||||
|
||||
: push-front ( deque item -- newdeque )
|
||||
|
@ -60,7 +58,7 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
: remove ( deque -- item newdeque )
|
||||
[ front>> car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline
|
||||
[ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline
|
||||
|
||||
: transfer ( deque -- item newdeque )
|
||||
back>> [ split-reverse deque boa remove ]
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs io kernel math models namespaces make dlists
|
||||
deques sequences threads sequences words continuations init
|
||||
deques sequences threads sequences words continuations init call
|
||||
combinators hashtables concurrency.flags sets accessors calendar fry
|
||||
ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks
|
||||
ui.gestures ui.backend ui.render ui.text ui.text.private ;
|
||||
|
@ -122,7 +122,7 @@ M: world ungraft*
|
|||
layout-queued
|
||||
redraw-worlds
|
||||
send-queued-gestures
|
||||
] assert-depth
|
||||
] call( -- )
|
||||
] [ ui-error ] recover ;
|
||||
|
||||
SYMBOL: ui-thread
|
||||
|
|
|
@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping"
|
|||
{ $subsection wrap-lines }
|
||||
{ $subsection wrap-string }
|
||||
{ $subsection wrap-indented-string }
|
||||
"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words."
|
||||
{ $subsection wrap }
|
||||
{ $subsection word }
|
||||
{ $subsection <word> } ;
|
||||
"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments."
|
||||
{ $subsection wrap-segments }
|
||||
{ $subsection segment }
|
||||
{ $subsection <segment> } ;
|
||||
|
||||
HELP: wrap-lines
|
||||
{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
|
||||
|
@ -27,15 +27,15 @@ HELP: wrap-indented-string
|
|||
{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
|
||||
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
|
||||
|
||||
HELP: wrap
|
||||
{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } }
|
||||
{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
|
||||
HELP: wrap-segments
|
||||
{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
|
||||
{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
|
||||
|
||||
HELP: word
|
||||
{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
|
||||
{ $see-also wrap } ;
|
||||
HELP: segment
|
||||
{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link <segment> } "." }
|
||||
{ $see-also wrap-segments } ;
|
||||
|
||||
HELP: <word>
|
||||
{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
|
||||
{ $description "Creates a " { $link word } " object with the given parameters." }
|
||||
{ $see-also wrap } ;
|
||||
HELP: <segment>
|
||||
{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } }
|
||||
{ $description "Creates a " { $link segment } " object with the given parameters." }
|
||||
{ $see-also wrap-segments } ;
|
||||
|
|
|
@ -6,49 +6,77 @@ IN: wrap.tests
|
|||
[
|
||||
{
|
||||
{
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 2 t }
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 2 t }
|
||||
}
|
||||
{
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
}
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 2 t }
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
} 35 wrap [ { } like ] map
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 2 t }
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
} 35 35 wrap-segments [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 3 9 t }
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 3 9 t }
|
||||
}
|
||||
{
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
}
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
} 35 wrap [ { } like ] map
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
} 35 35 wrap-segments [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ segment f 1 10 t }
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
}
|
||||
{
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
}
|
||||
{
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
}
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ segment f 1 10 t }
|
||||
T{ segment f 1 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 2 10 f }
|
||||
T{ segment f 3 9 t }
|
||||
T{ segment f 4 10 f }
|
||||
T{ segment f 5 10 f }
|
||||
} 35 35 wrap-segments [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -75,8 +103,16 @@ word wrap.">
|
|||
" " wrap-indented-string
|
||||
] unit-test
|
||||
|
||||
[ "this text\nhas lots of\nspaces" ]
|
||||
[ "this text\nhas lots\nof spaces" ]
|
||||
[ "this text has lots of spaces" 12 wrap-string ] unit-test
|
||||
|
||||
[ "hello\nhow\nare\nyou\ntoday?" ]
|
||||
[ "hello how are you today?" 3 wrap-string ] unit-test
|
||||
|
||||
[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
|
||||
|
||||
\ wrap-string must-infer
|
||||
\ wrap-segments must-infer
|
||||
|
|
|
@ -1,70 +1,154 @@
|
|||
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel namespaces make splitting
|
||||
math math.order fry assocs accessors ;
|
||||
USING: kernel sequences math arrays locals fry accessors
|
||||
lists splitting call make combinators.short-circuit namespaces
|
||||
grouping splitting.monotonic ;
|
||||
IN: wrap
|
||||
|
||||
! Word wrapping/line breaking -- not Unicode-aware
|
||||
|
||||
TUPLE: word key width break? ;
|
||||
|
||||
C: <word> word
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: width
|
||||
! black is the text length, white is the whitespace length
|
||||
TUPLE: element contents black white ;
|
||||
C: <element> element
|
||||
|
||||
: break-here? ( column word -- ? )
|
||||
break?>> not [ width get > ] [ drop f ] if ;
|
||||
: element-length ( element -- n )
|
||||
[ black>> ] [ white>> ] bi + ;
|
||||
|
||||
: walk ( n words -- n )
|
||||
! If on a break, take the rest of the breaks
|
||||
! If not on a break, go back until you hit a break
|
||||
2dup bounds-check? [
|
||||
2dup nth break?>>
|
||||
[ [ break?>> not ] find-from drop ]
|
||||
[ [ break?>> ] find-last-from drop 1+ ] if
|
||||
] [ drop ] if ;
|
||||
: swons ( cdr car -- cons )
|
||||
swap cons ;
|
||||
|
||||
: find-optimal-break ( words -- n )
|
||||
[ 0 ] keep
|
||||
[ [ width>> + dup ] keep break-here? ] find drop nip
|
||||
[ 1 max swap walk ] [ drop f ] if* ;
|
||||
: unswons ( cons -- cdr car )
|
||||
[ cdr ] [ car ] bi ;
|
||||
|
||||
: (wrap) ( words -- )
|
||||
: 1list? ( list -- ? )
|
||||
{ [ ] [ cdr +nil+ = ] } 1&& ;
|
||||
|
||||
: lists>arrays ( lists -- arrays )
|
||||
[ list>seq ] lmap>array ;
|
||||
|
||||
TUPLE: paragraph lines head-width tail-cost ;
|
||||
C: <paragraph> paragraph
|
||||
|
||||
SYMBOL: line-max
|
||||
SYMBOL: line-ideal
|
||||
|
||||
: deviation ( length -- n )
|
||||
line-ideal get - sq ;
|
||||
|
||||
: top-fits? ( paragraph -- ? )
|
||||
[ head-width>> ]
|
||||
[ lines>> 1list? line-ideal line-max ? get ] bi <= ;
|
||||
|
||||
: fits? ( paragraph -- ? )
|
||||
! Make this not count spaces at end
|
||||
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
|
||||
|
||||
:: min-by ( seq quot -- elt )
|
||||
f 1.0/0.0 seq [| key value new |
|
||||
new quot call :> newvalue
|
||||
newvalue value < [ new newvalue ] [ key value ] if
|
||||
] each drop ; inline
|
||||
|
||||
: paragraph-cost ( paragraph -- cost )
|
||||
[ head-width>> deviation ]
|
||||
[ tail-cost>> ] bi + ;
|
||||
|
||||
: min-cost ( paragraphs -- paragraph )
|
||||
[ paragraph-cost ] min-by ;
|
||||
|
||||
: new-line ( paragraph element -- paragraph )
|
||||
[ [ lines>> ] [ 1list ] bi* swons ]
|
||||
[ nip black>> ]
|
||||
[ drop paragraph-cost ] 2tri
|
||||
<paragraph> ;
|
||||
|
||||
: glue ( paragraph element -- paragraph )
|
||||
[ [ lines>> unswons ] dip swons swons ]
|
||||
[ [ head-width>> ] [ element-length ] bi* + ]
|
||||
[ drop tail-cost>> ] 2tri
|
||||
<paragraph> ;
|
||||
|
||||
: wrap-step ( paragraphs element -- paragraphs )
|
||||
[ '[ _ glue ] map ]
|
||||
[ [ min-cost ] dip new-line ]
|
||||
2bi prefix
|
||||
[ fits? ] filter ;
|
||||
|
||||
: 1paragraph ( element -- paragraph )
|
||||
[ 1list 1list ]
|
||||
[ black>> ] bi
|
||||
0 <paragraph> ;
|
||||
|
||||
: post-process ( paragraph -- array )
|
||||
lines>> lists>arrays
|
||||
[ [ contents>> ] map ] map ;
|
||||
|
||||
: initialize ( elements -- elements paragraph )
|
||||
<reversed> unclip-slice 1paragraph 1array ;
|
||||
|
||||
: wrap ( elements line-max line-ideal -- paragraph )
|
||||
[
|
||||
dup find-optimal-break
|
||||
[ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
|
||||
] unless-empty ;
|
||||
line-ideal set
|
||||
line-max set
|
||||
initialize
|
||||
[ wrap-step ] reduce
|
||||
min-cost
|
||||
post-process
|
||||
] with-scope ;
|
||||
|
||||
: intersperse ( seq elt -- seq' )
|
||||
[ '[ _ , ] [ , ] interleave ] { } make ;
|
||||
PRIVATE>
|
||||
|
||||
: split-lines ( string -- words-lines )
|
||||
TUPLE: segment key width break? ;
|
||||
C: <segment> segment
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: segments-length ( segments -- length )
|
||||
[ width>> ] map sum ;
|
||||
|
||||
: make-element ( whites blacks -- element )
|
||||
[ append ] [ [ segments-length ] bi@ ] 2bi <element> ;
|
||||
|
||||
: ?first2 ( seq -- first/f second/f )
|
||||
[ 0 swap ?nth ]
|
||||
[ 1 swap ?nth ] bi ;
|
||||
|
||||
: split-segments ( seq -- half-elements )
|
||||
[ [ break?>> ] bi@ = ] monotonic-split ;
|
||||
|
||||
: ?first-break ( seq -- newseq f/element )
|
||||
dup first first break?>>
|
||||
[ unclip-slice f swap make-element ]
|
||||
[ f ] if ;
|
||||
|
||||
: make-elements ( seq f/element -- elements )
|
||||
[ 2 <groups> [ ?first2 make-element ] map ] dip
|
||||
[ prefix ] when* ;
|
||||
|
||||
: segments>elements ( seq -- newseq )
|
||||
split-segments ?first-break make-elements ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wrap-segments ( segments line-max line-ideal -- lines )
|
||||
[ segments>elements ] 2dip wrap [ concat ] map ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: split-lines ( string -- elements-lines )
|
||||
string-lines [
|
||||
" \t" split harvest
|
||||
[ dup length f <word> ] map
|
||||
" " 1 t <word> intersperse
|
||||
[ dup length 1 <element> ] map
|
||||
] map ;
|
||||
|
||||
: join-words ( wrapped-lines -- lines )
|
||||
[
|
||||
[ break?>> ] trim-slice
|
||||
[ key>> ] map concat
|
||||
] map ;
|
||||
: join-elements ( wrapped-lines -- lines )
|
||||
[ " " join ] map ;
|
||||
|
||||
: join-lines ( strings -- string )
|
||||
"\n" join ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wrap ( words width -- lines )
|
||||
width [
|
||||
[ (wrap) ] { } make
|
||||
] with-variable ;
|
||||
|
||||
: wrap-lines ( lines width -- newlines )
|
||||
[ split-lines ] dip '[ _ wrap join-words ] map concat ;
|
||||
[ split-lines ] dip '[ _ dup wrap join-elements ] map concat ;
|
||||
|
||||
: wrap-string ( string width -- newstring )
|
||||
wrap-lines join-lines ;
|
||||
|
|
|
@ -138,3 +138,9 @@ USE: debugger.threads
|
|||
] with-file-reader
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"seek-test6" unique-file binary [
|
||||
-10 seek-absolute seek-input
|
||||
] with-file-reader
|
||||
] must-fail
|
||||
|
|
|
@ -2,20 +2,19 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io io.encodings.binary io.files
|
||||
kernel pack endian tools.hexdump constructors sequences arrays
|
||||
sorting.slots math.order math.parser prettyprint ;
|
||||
sorting.slots math.order math.parser prettyprint classes ;
|
||||
IN: graphics.tiff
|
||||
|
||||
TUPLE: tiff
|
||||
endianness
|
||||
the-answer
|
||||
ifd-offset
|
||||
ifds
|
||||
processed-ifds ;
|
||||
ifds ;
|
||||
|
||||
CONSTRUCTOR: tiff ( -- tiff )
|
||||
V{ } clone >>ifds ;
|
||||
|
||||
TUPLE: ifd count ifd-entries next ;
|
||||
TUPLE: ifd count ifd-entries next processed-tags strips ;
|
||||
|
||||
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
|
||||
|
||||
|
@ -137,8 +136,6 @@ ERROR: bad-planar-configuration n ;
|
|||
TUPLE: new-subfile-type n ;
|
||||
CONSTRUCTOR: new-subfile-type ( n -- object ) ;
|
||||
|
||||
|
||||
|
||||
ERROR: bad-tiff-magic bytes ;
|
||||
|
||||
: tiff-endianness ( byte-array -- ? )
|
||||
|
@ -176,6 +173,12 @@ ERROR: bad-tiff-magic bytes ;
|
|||
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
|
||||
] with-tiff-endianness ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
dup processed-tags>>
|
||||
[ [ strip-byte-counts instance? ] find nip n>> ]
|
||||
[ [ strip-offsets instance? ] find nip n>> ] bi
|
||||
[ seek-absolute seek-input read ] { } 2map-as >>strips ;
|
||||
|
||||
! ERROR: unhandled-ifd-entry data n ;
|
||||
|
||||
: unhandled-ifd-entry ;
|
||||
|
@ -207,17 +210,18 @@ ERROR: bad-tiff-magic bytes ;
|
|||
[ unhandled-ifd-entry swap 2array ]
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- processed-ifd )
|
||||
ifd-entries>> [ process-ifd-entry ] map ;
|
||||
: process-ifd ( ifd -- ifd )
|
||||
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
|
||||
|
||||
: (load-tiff) ( path -- tiff )
|
||||
binary [
|
||||
<tiff>
|
||||
read-header
|
||||
read-ifds
|
||||
dup ifds>> [ process-ifd ] map
|
||||
>>processed-ifds
|
||||
dup ifds>> [ process-ifd read-strips drop ] each
|
||||
] with-file-reader ;
|
||||
|
||||
: load-tiff ( path -- tiff )
|
||||
(load-tiff) ;
|
||||
|
||||
! TODO: duplicate ifds = error, seeking out of bounds = error
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
! Copyright (C) 2006 Matthew Willis and Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: lists lists.lazy tools.test kernel math io sequences ;
|
||||
IN: lists.lazy.tests
|
||||
|
||||
|
@ -27,3 +26,10 @@ IN: lists.lazy.tests
|
|||
[ { 4 5 6 } ] [
|
||||
3 { 1 2 3 } >list [ + ] lazy-map-with list>array
|
||||
] unit-test
|
||||
|
||||
[ [ ] lmap ] must-infer
|
||||
[ [ ] lmap>array ] must-infer
|
||||
[ [ drop ] foldr ] must-infer
|
||||
[ [ drop ] foldl ] must-infer
|
||||
[ [ drop ] leach ] must-infer
|
||||
[ lnth ] must-infer
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
! Updated by James Cash, June 2008
|
||||
!
|
||||
USING: kernel sequences math vectors arrays namespaces make
|
||||
quotations promises combinators io lists accessors ;
|
||||
quotations promises combinators io lists accessors call ;
|
||||
IN: lists.lazy
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
|
@ -86,7 +81,7 @@ C: <lazy-map> lazy-map
|
|||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ cons>> car ] keep
|
||||
quot>> call ;
|
||||
quot>> call( old -- new ) ;
|
||||
|
||||
M: lazy-map cdr ( lazy-map -- cdr )
|
||||
[ cons>> cdr ] keep
|
||||
|
@ -130,7 +125,7 @@ M: lazy-until car ( lazy-until -- car )
|
|||
cons>> car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ cons>> uncons ] keep quot>> tuck call
|
||||
[ cons>> uncons ] keep quot>> tuck call( elt -- ? )
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
|
@ -150,7 +145,7 @@ M: lazy-while cdr ( lazy-while -- cdr )
|
|||
[ cons>> cdr ] keep quot>> lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep quot>> call not ;
|
||||
[ car ] keep quot>> call( elt -- ? ) not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
|
@ -160,7 +155,7 @@ C: <lazy-filter> lazy-filter
|
|||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ cons>> car ] [ quot>> ] bi call ;
|
||||
[ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
dup cons>> cdr >>cons drop ;
|
||||
|
@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car )
|
|||
|
||||
M: lazy-from-by cdr ( lazy-from-by -- cdr )
|
||||
[ n>> ] keep
|
||||
quot>> dup slip lfrom-by ;
|
||||
quot>> [ call( old -- new ) ] keep lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car )
|
|||
dup car>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup stream>> over quot>> call
|
||||
drop dup stream>> over quot>>
|
||||
call( stream -- value )
|
||||
>>car
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors math arrays vectors classes words locals ;
|
||||
|
||||
IN: lists
|
||||
|
||||
! List Protocol
|
||||
|
@ -46,7 +45,7 @@ M: object nil? drop f ;
|
|||
: 2car ( cons -- car caar )
|
||||
[ car ] [ cdr car ] bi ;
|
||||
|
||||
: 3car ( cons -- car caar caaar )
|
||||
: 3car ( cons -- car cadr caddr )
|
||||
[ car ] [ cdr car ] [ cdr cdr car ] tri ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
|
@ -109,4 +108,4 @@ M: object nil? drop f ;
|
|||
[ 2over call [ tuck [ call ] 2dip ] when
|
||||
pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive
|
||||
|
||||
INSTANCE: cons list
|
||||
INSTANCE: cons list
|
||||
|
|
|
@ -1,10 +1,6 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
|
||||
USING: arrays kernel sequences math vectors arrays namespaces
|
||||
USING: arrays kernel sequences math vectors arrays namespaces call
|
||||
make quotations parser effects stack-checker words accessors ;
|
||||
IN: promises
|
||||
|
||||
|
@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ;
|
|||
#! promises quotation on the stack. Re-forcing the promise
|
||||
#! will return the same value and not recall the quotation.
|
||||
dup forced?>> [
|
||||
dup quot>> call >>value
|
||||
dup quot>> call( -- value ) >>value
|
||||
t >>forced?
|
||||
] unless
|
||||
value>> ;
|
||||
|
|
Loading…
Reference in New Issue