Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
35dc7ae429
|
|
@ -1,4 +1,4 @@
|
|||
USING: strings.parser kernel namespaces unicode.data ;
|
||||
USING: strings.parser kernel namespaces unicode unicode.data ;
|
||||
IN: bootstrap.unicode
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,39 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.breaks
|
||||
|
||||
ABOUT: "unicode.breaks"
|
||||
|
||||
ARTICLE: "unicode.breaks" "Word and grapheme breaks"
|
||||
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
|
||||
$nl "Operations for graphemes:"
|
||||
{ $subsection first-grapheme }
|
||||
{ $subsection last-grapheme }
|
||||
{ $subsection >graphemes }
|
||||
{ $subsection string-reverse }
|
||||
"Operations on words:"
|
||||
{ $subsection first-word }
|
||||
{ $subsection >words } ;
|
||||
|
||||
HELP: first-grapheme
|
||||
{ $values { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the length of the first grapheme of the string. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
|
||||
|
||||
HELP: last-grapheme
|
||||
{ $values { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
|
||||
|
||||
HELP: >graphemes
|
||||
{ $values { "str" string } { "graphemes" "an array of strings" } }
|
||||
{ $description "Divides a string into a sequence of individual graphemes." } ;
|
||||
|
||||
HELP: string-reverse
|
||||
{ $values { "str" string } { "rts" string } }
|
||||
{ $description "Reverses a string, leaving graphemes in-tact." } ;
|
||||
|
||||
HELP: first-word
|
||||
{ $values { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the length of the first word in the string." } ;
|
||||
|
||||
HELP: >words
|
||||
{ $values { "str" string } { "words" "an array of strings" } }
|
||||
{ $description "Divides the string up into words." } ;
|
||||
|
|
@ -36,4 +36,4 @@ IN: unicode.breaks.tests
|
|||
] each ;
|
||||
|
||||
grapheme-break-test parse-test-file [ >graphemes ] test
|
||||
! word-break-test parse-test-file [ >words ] test
|
||||
word-break-test parse-test-file [ >words ] test
|
||||
|
|
|
|||
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit unicode.categories kernel math
|
||||
combinators splitting sequences math.parser io.files io assocs
|
||||
arrays namespaces make math.ranges unicode.normalize values
|
||||
arrays namespaces make math.ranges unicode.normalize.private values
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units
|
||||
alien.syntax sets accessors interval-maps memoize locals words ;
|
||||
IN: unicode.breaks
|
||||
|
||||
<PRIVATE
|
||||
! Grapheme breaks
|
||||
|
||||
C-ENUM: Any L V T LV LVT Extend Control CR LF
|
||||
|
|
@ -101,19 +102,25 @@ VALUE: grapheme-table
|
|||
: find-index ( seq quot -- i ) find drop ; inline
|
||||
: find-last-index ( seq quot -- i ) find-last drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: first-grapheme ( str -- i )
|
||||
unclip-slice grapheme-class over
|
||||
[ grapheme-class tuck grapheme-break? ] find-index
|
||||
nip swap length or 1+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (>pieces) ( str quot -- )
|
||||
str [
|
||||
dup quot call cut-slice
|
||||
swap , quot (>pieces)
|
||||
] unless-empty ;
|
||||
] unless-empty ; inline recursive
|
||||
|
||||
: >pieces ( str quot -- graphemes )
|
||||
[ (>pieces) ] { } make ;
|
||||
[ (>pieces) ] { } make ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >graphemes ( str -- graphemes )
|
||||
[ first-grapheme ] >pieces ;
|
||||
|
|
@ -125,6 +132,8 @@ VALUE: grapheme-table
|
|||
unclip-last-slice grapheme-class swap
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
graphemes init-table table
|
||||
[ make-grapheme-table finish-table ] with-variable
|
||||
to: grapheme-table
|
||||
|
|
@ -139,14 +148,14 @@ to: word-break-table
|
|||
C-ENUM: wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
|
||||
wMidNum wMidNumLet wNumeric wExtendNumLet words ;
|
||||
|
||||
MEMO: word-break-classes ( -- table )
|
||||
: word-break-classes ( -- table ) ! Is there a way to avoid this?
|
||||
H{
|
||||
{ "Other" wOther } { "CR" wCR } { "LF" wLF } { "Newline" wNewline }
|
||||
{ "Extend" wExtend } { "Format" wFormat } { "Katakana" wKatakana }
|
||||
{ "ALetter" wALetter } { "MidLetter" wMidLetter }
|
||||
{ "MidNum" wMidNum } { "MidNumLet" wMidNumLet } { "Numeric" wNumeric }
|
||||
{ "ExtendNumLet" wExtendNumLet }
|
||||
} [ execute ] assoc-map ;
|
||||
{ "Other" 0 } { "CR" 1 } { "LF" 2 } { "Newline" 3 }
|
||||
{ "Extend" 4 } { "Format" 5 } { "Katakana" 6 }
|
||||
{ "ALetter" 7 } { "MidLetter" 8 }
|
||||
{ "MidNum" 9 } { "MidNumLet" 10 } { "Numeric" 11 }
|
||||
{ "ExtendNumLet" 12 }
|
||||
} ;
|
||||
|
||||
: word-break-prop ( char -- word-break-prop )
|
||||
word-break-table interval-at
|
||||
|
|
@ -185,22 +194,51 @@ words init-table table
|
|||
[ make-word-table finish-word-table ] with-variable
|
||||
to: word-table
|
||||
|
||||
: word-break? ( class1 class2 -- ? )
|
||||
word-table nth nth not ;
|
||||
: word-table-nth ( class1 class2 -- ? )
|
||||
word-table nth nth ;
|
||||
|
||||
: skip? ( char -- ? )
|
||||
word-break-prop { 4 5 } member? ; ! wExtend or wFormat
|
||||
: property-not= ( i str property -- ? )
|
||||
pick [
|
||||
[ ?nth ] dip swap
|
||||
[ word-break-prop = not ] [ drop f ] if*
|
||||
] [ 3drop t ] if ;
|
||||
|
||||
: word-break-next ( old-class new-char -- next-class ? )
|
||||
word-break-prop dup { 4 5 } member?
|
||||
[ drop f ] [ tuck word-break? ] if ;
|
||||
: format/extended? ( ch -- ? )
|
||||
word-break-prop { 4 5 } member? ;
|
||||
|
||||
: first-word ( str -- i )
|
||||
unclip-slice word-break-prop over
|
||||
[ word-break-next ] find-index
|
||||
:: walk-up ( str i -- j )
|
||||
i 1 + str [ format/extended? not ] find-from drop
|
||||
1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
|
||||
|
||||
:: walk-down ( str i -- j )
|
||||
i str [ format/extended? not ] find-last-from drop
|
||||
1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
|
||||
|
||||
:: word-break? ( table-entry i str -- ? )
|
||||
table-entry {
|
||||
{ t [ f ] }
|
||||
{ f [ t ] }
|
||||
{ check-letter-after
|
||||
[ str i walk-up str wALetter property-not= ] }
|
||||
{ check-letter-before
|
||||
[ str i walk-down str wALetter property-not= ] }
|
||||
{ check-number-after
|
||||
[ str i walk-up str wNumeric property-not= ] }
|
||||
{ check-number-before
|
||||
[ str i walk-down str wNumeric property-not= ] }
|
||||
} case ;
|
||||
|
||||
:: word-break-next ( old-class new-char i str -- next-class ? )
|
||||
new-char word-break-prop dup { 4 5 } member?
|
||||
[ drop old-class dup { 1 2 3 } member? ]
|
||||
[ old-class over word-table-nth i str word-break? ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: first-word ( str -- i )
|
||||
str unclip-slice word-break-prop over <enum>
|
||||
[ swap str word-break-next ] assoc-find 2drop
|
||||
nip swap length or 1+ ;
|
||||
! This must be changed to ignore format/extended chars and
|
||||
! handle symbols in the table specially
|
||||
|
||||
: >words ( str -- words )
|
||||
[ first-word ] >pieces ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: unicode.case
|
||||
|
||||
ABOUT: "unicode.case"
|
||||
|
||||
ARTICLE: "unicode.case" "Case mapping"
|
||||
"When considering Unicode in general and not just ASCII or a smaller character set, putting a string in upper case, title case or lower case is slightly more complicated. In most contexts it's best to use the general Unicode routines for case conversion. There is an additional type of casing, case-fold, which is defined as bringing a string into upper case and then lower. This exists because in some cases it is different from simple lower case."
|
||||
{ $subsection >upper }
|
||||
{ $subsection >lower }
|
||||
{ $subsection >title }
|
||||
{ $subsection >case-fold }
|
||||
"To test if a string is in a given case:"
|
||||
{ $subsection upper? }
|
||||
{ $subsection lower? }
|
||||
{ $subsection title? }
|
||||
{ $subsection case-fold? }
|
||||
"For certain languages (Turkish, Azeri, Lithuanian), case mapping is dependent on locale; To change this, set the following variable to the ISO-639-1 code for your language:"
|
||||
{ $subsection locale }
|
||||
"This is unnecessary for most languages." ;
|
||||
|
|
@ -5,14 +5,15 @@ unicode.normalize math unicode.categories combinators
|
|||
assocs strings splitting kernel accessors ;
|
||||
IN: unicode.case
|
||||
|
||||
<PRIVATE
|
||||
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
|
||||
|
||||
: ch>lower ( ch -- lower ) simple-lower at-default ;
|
||||
: ch>upper ( ch -- upper ) simple-upper at-default ;
|
||||
: ch>title ( ch -- title ) simple-title at-default ;
|
||||
|
||||
PRIVATE>
|
||||
SYMBOL: locale ! Just casing locale, or overall?
|
||||
|
||||
<PRIVATE
|
||||
: i-dot? ( -- ? )
|
||||
locale get { "tr" "az" } member? ;
|
||||
|
||||
|
|
@ -79,7 +80,7 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
[ [ % ] compose ] [ [ , ] compose ] bi* ?if
|
||||
] 2curry each
|
||||
] "" make ; inline
|
||||
|
||||
PRIVATE>
|
||||
: >lower ( string -- lower )
|
||||
i-dot? [ turk>lower ] when
|
||||
final-sigma [ lower>> ] [ ch>lower ] map-case ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
! Copyright (C) 2009 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: unicode.categories
|
||||
|
||||
HELP: LETTER?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is an upper-cased letter" } ;
|
||||
|
||||
HELP: Letter?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is a letter of any case" } ;
|
||||
|
||||
HELP: alpha?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is alphanumeric" } ;
|
||||
|
||||
HELP: blank?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is whitespace" } ;
|
||||
|
||||
HELP: character?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a number is a code point which has been assigned" } ;
|
||||
|
||||
HELP: control?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a control character" } ;
|
||||
|
||||
HELP: digit?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a digit" } ;
|
||||
|
||||
HELP: letter?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a lower-cased letter" } ;
|
||||
|
||||
HELP: printable?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is printable, as opposed to being a control character or formatting character" } ;
|
||||
|
||||
HELP: uncased?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a character has a case" } ;
|
||||
|
||||
ARTICLE: "unicode.categories" "Character classes"
|
||||
{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ASCII" "ascii" } " equivalents in most cases. Below are links to the useful predicates, but note that each of these is defined to be a predicate class."
|
||||
{ $subsection blank? }
|
||||
{ $subsection letter? }
|
||||
{ $subsection LETTER? }
|
||||
{ $subsection Letter? }
|
||||
{ $subsection digit? }
|
||||
{ $subsection printable? }
|
||||
{ $subsection alpha? }
|
||||
{ $subsection control? }
|
||||
{ $subsection uncased? }
|
||||
{ $subsection character? } ;
|
||||
|
||||
ABOUT: "unicode.categories"
|
||||
|
|
@ -1,10 +1,8 @@
|
|||
USING: help.syntax help.markup strings byte-arrays ;
|
||||
IN: unicode.collation
|
||||
|
||||
ABOUT: "unicode.collation"
|
||||
|
||||
ARTICLE: "unicode.collation" "Unicode collation algorithm (UCA)"
|
||||
"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
ARTICLE: "unicode.collation" "Collation and weak comparison"
|
||||
"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
{ $subsection sort-strings }
|
||||
{ $subsection collation-key }
|
||||
{ $subsection string<=> }
|
||||
|
|
@ -13,6 +11,8 @@ ARTICLE: "unicode.collation" "Unicode collation algorithm (UCA)"
|
|||
{ $subsection tertiary= }
|
||||
{ $subsection quaternary= } ;
|
||||
|
||||
ABOUT: "unicode.collation"
|
||||
|
||||
HELP: sort-strings
|
||||
{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
|
||||
{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.normalize
|
||||
|
||||
ABOUT: "unicode.normalize"
|
||||
|
||||
ARTICLE: "unicode.normalize" "Unicode normalization"
|
||||
"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings. In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: \"e\\u000301\" (the e character, followed by the combining acute accent character) and \"\\u0000e9\" (a single character, e with an acute accent). There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care. Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
|
||||
{ $subsection nfc }
|
||||
{ $subsection nfd }
|
||||
{ $subsection nfkc }
|
||||
{ $subsection nfkd }
|
||||
"If two strings in a normalization form are appended, the result may not be in that normalization form still. To append two strings in NFD and make sure the result is in NFD, the following procedure is supplied:"
|
||||
{ $subsection string-append } ;
|
||||
|
||||
HELP: nfc
|
||||
{ $values { "string" string } { "nfc" "a string in NFC" } }
|
||||
{ $description "Converts a string to Normalization Form C" } ;
|
||||
|
||||
HELP: nfd
|
||||
{ $values { "string" string } { "nfd" "a string in NFD" } }
|
||||
{ $description "Converts a string to Normalization Form D" } ;
|
||||
|
||||
HELP: nfkc
|
||||
{ $values { "string" string } { "nfkc" "a string in NFKC" } }
|
||||
{ $description "Converts a string to Normalization Form KC" } ;
|
||||
|
||||
HELP: nfkd
|
||||
{ $values { "string" string } { "nfc" "a string in NFKD" } }
|
||||
{ $description "Converts a string to Normalization Form KD" } ;
|
||||
|
||||
HELP: string-append
|
||||
{ $values { "s1" "a string in NFD" } { "s2" "a string in NFD" } { "string" "a string in NFD" } }
|
||||
{ $description "Appends two strings, putting the result in NFD." } ;
|
||||
|
|
@ -4,6 +4,7 @@ USING: sequences namespaces make unicode.data kernel math arrays
|
|||
locals sorting.insertion accessors assocs ;
|
||||
IN: unicode.normalize
|
||||
|
||||
<PRIVATE
|
||||
! Conjoining Jamo behavior
|
||||
|
||||
: hangul-base HEX: ac00 ; inline
|
||||
|
|
@ -74,10 +75,12 @@ IN: unicode.normalize
|
|||
dup reorder
|
||||
] if ; inline
|
||||
|
||||
: nfd ( string -- string )
|
||||
PRIVATE>
|
||||
|
||||
: nfd ( string -- nfd )
|
||||
[ canonical-entry ] decompose ;
|
||||
|
||||
: nfkd ( string -- string )
|
||||
: nfkd ( string -- nfkd )
|
||||
[ compatibility-entry ] decompose ;
|
||||
|
||||
: string-append ( s1 s2 -- string )
|
||||
|
|
@ -87,6 +90,8 @@ IN: unicode.normalize
|
|||
0 over ?nth non-starter?
|
||||
[ length dupd reorder-back ] [ drop ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Normalization -- Composition
|
||||
SYMBOL: main-str
|
||||
SYMBOL: ind
|
||||
|
|
@ -157,6 +162,8 @@ DEFER: compose-iter
|
|||
pass-combining (compose)
|
||||
] "" make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: nfc ( string -- nfc )
|
||||
nfd compose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: unicode
|
||||
|
||||
ARTICLE: "unicode" "Unicode"
|
||||
"Unicode is a set of characters, or " { $emphasis "code points" } " covering what's used in most world writing systems. Any Factor string can hold any of these code points transparently; a factor string is a sequence of Unicode code points. Unicode is accompanied by several standard algorithms for common operations like encoding in files, capitalizing a string, finding the boundaries between words, etc. When a programmer is faced with a string manipulation problem, where the string represents human language, a Unicode algorithm is often much better than the naive one. This is not in terms of efficiency, but rather internationalization. Even English text that remains in ASCII is better served by the Unicode collation algorithm than a naive algorithm. The Unicode algorithms implemented here are:"
|
||||
{ $vocab-subsection "Case mapping" "unicode.case" }
|
||||
{ $vocab-subsection "Collation and weak comparison" "unicode.collation" }
|
||||
{ $vocab-subsection "Character classes" "unicode.categories" }
|
||||
{ $vocab-subsection "Word and grapheme breaks" "unicode.breaks" }
|
||||
{ $vocab-subsection "Unicode normalization" "unicode.normalize" }
|
||||
"The following are mostly for internal use:"
|
||||
{ $vocab-subsection "Unicode syntax" "unicode.syntax" }
|
||||
{ $vocab-subsection "Unicode data tables" "unicode.data" }
|
||||
{ $see-also "io.encodings" } ;
|
||||
|
||||
ABOUT: "unicode"
|
||||
|
|
@ -0,0 +1 @@
|
|||
IN: unicode
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
|
||||
USING: accessors arrays assocs colors combinators.short-circuit
|
||||
kernel locals math math.functions math.matrices math.order
|
||||
math.parser math.trig math.vectors opengl opengl.demo-support
|
||||
opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ;
|
||||
USING: accessors arrays assocs calendar colors
|
||||
combinators.short-circuit help.markup help.syntax kernel locals
|
||||
math math.functions math.matrices math.order math.parser
|
||||
math.trig math.vectors opengl opengl.demo-support opengl.gl
|
||||
sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ui.tools.workspace ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -255,8 +256,26 @@ DEFER: default-L-parser-values
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <L-system> < gadget
|
||||
camera display-list
|
||||
commands axiom rules string ;
|
||||
camera display-list pedestal paused commands axiom rules string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-rotation-thread ( GADGET -- )
|
||||
GADGET f >>paused drop
|
||||
[
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -332,7 +351,7 @@ TUPLE: <L-system> < gadget
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-L-system-string ( L-SYSTEM -- )
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM string>> L-SYSTEM axiom>> or
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
|
|
@ -357,7 +376,7 @@ TUPLE: <L-system> < gadget
|
|||
L-SYSTEM display-list>> GL_COMPILE glNewList
|
||||
|
||||
turtle
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM string>> L-SYSTEM axiom>> or
|
||||
L-SYSTEM commands>>
|
||||
interpret-string
|
||||
drop
|
||||
|
|
@ -387,6 +406,10 @@ M:: <L-system> draw-gadget* ( L-SYSTEM -- )
|
|||
! draw axis
|
||||
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
! rotate pedestal
|
||||
|
||||
L-SYSTEM pedestal>> 0 0 1 glRotated
|
||||
|
||||
L-SYSTEM display-list>> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -403,16 +426,12 @@ M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: camera-left ( L-SYSTEM -- )
|
||||
L-SYSTEM camera>> 5 turn-left drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: with-camera ( L-SYSTEM QUOT -- )
|
||||
L-SYSTEM camera>> QUOT call drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
<L-system>
|
||||
H{
|
||||
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
|
||||
|
|
@ -423,6 +442,11 @@ H{
|
|||
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
|
||||
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
|
||||
{ T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "r" } [ start-rotation-thread ] }
|
||||
|
||||
{
|
||||
T{ key-down f f "x" }
|
||||
[
|
||||
|
|
@ -432,6 +456,8 @@ H{
|
|||
drop
|
||||
]
|
||||
}
|
||||
|
||||
{ T{ key-down f f "F1" } [ drop "L-system" help-window ] }
|
||||
|
||||
}
|
||||
set-gestures
|
||||
|
|
@ -441,8 +467,36 @@ set-gestures
|
|||
: L-system ( -- L-system )
|
||||
|
||||
<L-system> new-gadget
|
||||
|
||||
0 >>pedestal
|
||||
|
||||
turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
|
||||
turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
|
||||
|
||||
dup start-rotation-thread
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "L-system" "L-system"
|
||||
|
||||
"Press 'x' to iterate the L-system." $nl
|
||||
|
||||
"Camera control:"
|
||||
|
||||
{ $table
|
||||
|
||||
{ "a" "Forward" }
|
||||
{ "z" "Backward" }
|
||||
|
||||
{ "LEFT" "Turn left" }
|
||||
{ "RIGHT" "Turn right" }
|
||||
{ "UP" "Pitch down" }
|
||||
{ "DOWN" "Pitch up" }
|
||||
|
||||
{ "q" "Roll left" }
|
||||
{ "w" "Roll right" } } ;
|
||||
|
||||
ABOUT: "L-system"
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: accessors kernel ui L-system ;
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-1
|
||||
|
||||
|
|
@ -12,15 +12,13 @@ IN: L-system.models.abop-1
|
|||
"c(12)FFAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
{ "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
|
||||
{ "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
|
||||
{ "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
{ "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
|
||||
}
|
||||
>>rules
|
||||
|
||||
dup axiom>> >>string ;
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,28 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-2
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-2 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
"c(12)FAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
|
||||
{ "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
|
||||
{ "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
|
||||
|
||||
} >>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
Loading…
Reference in New Issue