Merge branch 'master' of git://factorcode.org/git/factor
|
@ -0,0 +1,47 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel strings words ;
|
||||
IN: tools.scaffold
|
||||
|
||||
HELP: developer-name
|
||||
{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
|
||||
{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
|
||||
|
||||
HELP: help.
|
||||
{ $values
|
||||
{ "word" word } }
|
||||
{ $description "Prints out scaffold help markup for a given word." } ;
|
||||
|
||||
HELP: scaffold-help
|
||||
{ $values
|
||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
|
||||
|
||||
HELP: scaffold-undocumented
|
||||
{ $values
|
||||
{ "string" string } }
|
||||
{ $description "Prints scaffolding documenation for undocumented words in a vocabuary except for automatically generated class predicates." } ;
|
||||
|
||||
{ scaffold-help scaffold-undocumented } related-words
|
||||
|
||||
HELP: scaffold-vocab
|
||||
{ $values
|
||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
|
||||
HELP: using
|
||||
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
|
||||
|
||||
ARTICLE: "tools.scaffold" "Scaffold tool"
|
||||
"Scaffold setup:"
|
||||
{ $subsection developer-name }
|
||||
"Generate new vocabs:"
|
||||
{ $subsection scaffold-vocab }
|
||||
"Generate help scaffolding:"
|
||||
{ $subsection scaffold-help }
|
||||
{ $subsection scaffold-undocumented }
|
||||
{ $subsection help. }
|
||||
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
|
||||
;
|
||||
|
||||
ABOUT: "tools.scaffold"
|
|
@ -4,19 +4,21 @@ USING: assocs io.files hashtables kernel namespaces sequences
|
|||
vocabs.loader io combinators io.encodings.utf8 calendar accessors
|
||||
math.parser io.streams.string ui.tools.operations quotations
|
||||
strings arrays prettyprint words vocabs sorting sets cords
|
||||
sequences.lib combinators.lib ;
|
||||
classes sequences.lib combinators.lib ;
|
||||
IN: tools.scaffold
|
||||
|
||||
SYMBOL: developer-name
|
||||
SYMBOL: using
|
||||
|
||||
ERROR: not-a-vocab-root string ;
|
||||
ERROR: vocab-name-contains-separator path ;
|
||||
ERROR: vocab-name-contains-dot path ;
|
||||
ERROR: no-vocab vocab ;
|
||||
|
||||
<PRIVATE
|
||||
: root? ( string -- ? )
|
||||
vocab-roots get member? ;
|
||||
|
||||
ERROR: vocab-name-contains-separator path ;
|
||||
ERROR: vocab-name-contains-dot path ;
|
||||
: check-vocab-name ( string -- string )
|
||||
dup dup [ CHAR: . = ] trim [ length ] bi@ =
|
||||
[ vocab-name-contains-dot ] unless
|
||||
|
@ -109,7 +111,7 @@ ERROR: vocab-name-contains-dot path ;
|
|||
} at* ;
|
||||
|
||||
: add-using ( object -- )
|
||||
vocabulary>> using get conjoin ;
|
||||
vocabulary>> using get [ conjoin ] [ drop ] if* ;
|
||||
|
||||
: ($values.) ( array -- )
|
||||
[
|
||||
|
@ -140,18 +142,26 @@ ERROR: vocab-name-contains-dot path ;
|
|||
|
||||
: $description. ( word -- )
|
||||
drop
|
||||
"{ $description } ;" print ;
|
||||
"{ $description \"\" } ;" print ;
|
||||
|
||||
: help-header. ( word -- )
|
||||
"HELP: " write name>> print ;
|
||||
|
||||
: help. ( word -- )
|
||||
: (help.) ( word -- )
|
||||
[ help-header. ] [ $values. ] [ $description. ] tri ;
|
||||
|
||||
: interesting-words ( vocab -- array )
|
||||
words
|
||||
[ [ "help" word-prop ] [ predicate? ] bi or not ] filter
|
||||
natural-sort ;
|
||||
|
||||
: interesting-words. ( vocab -- )
|
||||
interesting-words [ (help.) nl ] each ;
|
||||
|
||||
: help-file-string ( str1 -- str2 )
|
||||
[
|
||||
[ "IN: " write print nl ]
|
||||
[ words natural-sort [ help. nl ] each ]
|
||||
[ interesting-words. ]
|
||||
[ "ARTICLE: " write unparse dup write bl print ";" print nl ]
|
||||
[ "ABOUT: " write unparse print ] quad
|
||||
] with-string-writer ;
|
||||
|
@ -178,12 +188,33 @@ ERROR: vocab-name-contains-dot path ;
|
|||
: prepare-scaffold ( vocab-root string -- string path )
|
||||
check-scaffold [ vocab>scaffold-path ] keep ;
|
||||
|
||||
: with-scaffold ( quot -- )
|
||||
[ H{ } clone using ] dip with-variable ; inline
|
||||
|
||||
: check-vocab ( vocab -- vocab )
|
||||
dup find-vocab-root [ no-vocab ] unless ;
|
||||
PRIVATE>
|
||||
|
||||
: link-vocab ( vocab -- )
|
||||
check-vocab
|
||||
"Edit documentation: " write
|
||||
[ find-vocab-root ] keep
|
||||
[ append-path ] keep "-docs.factor" append append-path
|
||||
<pathname> . ;
|
||||
|
||||
: help. ( word -- )
|
||||
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
|
||||
|
||||
: scaffold-help ( vocab-root string -- )
|
||||
H{ } clone using [
|
||||
[
|
||||
check-vocab
|
||||
prepare-scaffold
|
||||
[ "-docs.factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-help-file ] [ 2drop ] if
|
||||
] with-variable ;
|
||||
] with-scaffold ;
|
||||
|
||||
: scaffold-undocumented ( string -- )
|
||||
[ interesting-words. ] [ link-vocab ] bi ;
|
||||
|
||||
: scaffold-vocab ( vocab-root string -- )
|
||||
prepare-scaffold
|
||||
|
|
|
@ -22,7 +22,7 @@ SYMBOLS:
|
|||
: (offsetof) ( field struct -- offset )
|
||||
[ (field-spec-of) offset>> ] [ drop 0 ] if* ;
|
||||
: (sizeof) ( field struct -- size )
|
||||
[ (field-spec-of) class>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
|
||||
[ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
|
||||
|
||||
: (flag) ( thing -- integer )
|
||||
{
|
||||
|
|
|
@ -4,7 +4,8 @@
|
|||
USING: alien arrays byte-arrays combinators summary
|
||||
io.backend graphics.viewer io io.binary io.files kernel libc
|
||||
math math.functions namespaces opengl opengl.gl prettyprint
|
||||
sequences strings ui ui.gadgets.panes io.encodings.binary ;
|
||||
sequences strings ui ui.gadgets.panes io.encodings.binary
|
||||
accessors ;
|
||||
IN: graphics.bitmap
|
||||
|
||||
! Currently can only handle 24bit bitmaps.
|
||||
|
@ -31,36 +32,35 @@ M: bitmap-magic summary
|
|||
drop "First two bytes of bitmap stream must be 'BM'" ;
|
||||
|
||||
: parse-file-header ( bitmap -- )
|
||||
2 read >string dup "BM" = [ bitmap-magic ] unless
|
||||
over set-bitmap-magic
|
||||
4 read le> over set-bitmap-size
|
||||
4 read le> over set-bitmap-reserved
|
||||
4 read le> swap set-bitmap-offset ;
|
||||
2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
|
||||
4 read le> >>size
|
||||
4 read le> >>reserved
|
||||
4 read le> >>offset drop ;
|
||||
|
||||
: parse-bitmap-header ( bitmap -- )
|
||||
4 read le> over set-bitmap-header-length
|
||||
4 read le> over set-bitmap-width
|
||||
4 read le> over set-bitmap-height
|
||||
2 read le> over set-bitmap-planes
|
||||
2 read le> over set-bitmap-bit-count
|
||||
4 read le> over set-bitmap-compression
|
||||
4 read le> over set-bitmap-size-image
|
||||
4 read le> over set-bitmap-x-pels
|
||||
4 read le> over set-bitmap-y-pels
|
||||
4 read le> over set-bitmap-color-used
|
||||
4 read le> swap set-bitmap-color-important ;
|
||||
4 read le> >>header-length
|
||||
4 read le> >>width
|
||||
4 read le> >>height
|
||||
2 read le> >>planes
|
||||
2 read le> >>bit-count
|
||||
4 read le> >>compression
|
||||
4 read le> >>size-image
|
||||
4 read le> >>x-pels
|
||||
4 read le> >>y-pels
|
||||
4 read le> >>color-used
|
||||
4 read le> >>color-important drop ;
|
||||
|
||||
: rgb-quads-length ( bitmap -- n )
|
||||
[ bitmap-offset 14 - ] keep bitmap-header-length - ;
|
||||
[ offset>> 14 - ] keep header-length>> - ;
|
||||
|
||||
: color-index-length ( bitmap -- n )
|
||||
[ bitmap-width ] keep [ bitmap-planes * ] keep
|
||||
[ bitmap-bit-count * 31 + 32 /i 4 * ] keep
|
||||
bitmap-height abs * ;
|
||||
[ width>> ] keep [ planes>> * ] keep
|
||||
[ bit-count>> * 31 + 32 /i 4 * ] keep
|
||||
height>> abs * ;
|
||||
|
||||
: parse-bitmap ( bitmap -- )
|
||||
dup rgb-quads-length read over set-bitmap-rgb-quads
|
||||
dup color-index-length read swap set-bitmap-color-index ;
|
||||
dup rgb-quads-length read >>rgb-quads
|
||||
dup color-index-length read >>color-index drop ;
|
||||
|
||||
: load-bitmap ( path -- bitmap )
|
||||
normalize-path binary [
|
||||
|
@ -69,50 +69,52 @@ M: bitmap-magic summary
|
|||
dup parse-bitmap-header
|
||||
dup parse-bitmap
|
||||
] with-file-reader
|
||||
dup bitmap-color-index over bitmap-bit-count
|
||||
raw-bitmap>string >byte-array over set-bitmap-array ;
|
||||
dup color-index>> over bit-count>>
|
||||
raw-bitmap>string >byte-array >>array ;
|
||||
|
||||
: save-bitmap ( bitmap path -- )
|
||||
binary [
|
||||
"BM" write
|
||||
dup bitmap-array length 14 + 40 + 4 >le write
|
||||
dup array>> length 14 + 40 + 4 >le write
|
||||
0 4 >le write
|
||||
54 4 >le write
|
||||
|
||||
40 4 >le write
|
||||
dup bitmap-width 4 >le write
|
||||
dup bitmap-height 4 >le write
|
||||
dup bitmap-planes 1 or 2 >le write
|
||||
dup bitmap-bit-count 24 or 2 >le write
|
||||
dup bitmap-compression 0 or 4 >le write
|
||||
dup bitmap-size-image 4 >le write
|
||||
dup bitmap-x-pels 4 >le write
|
||||
dup bitmap-y-pels 4 >le write
|
||||
dup bitmap-color-used 4 >le write
|
||||
dup bitmap-color-important 4 >le write
|
||||
dup bitmap-rgb-quads write
|
||||
bitmap-color-index write
|
||||
{
|
||||
[ width>> 4 >le write ]
|
||||
[ height>> 4 >le write ]
|
||||
[ planes>> 1 or 2 >le write ]
|
||||
[ bit-count>> 24 or 2 >le write ]
|
||||
[ compression>> 0 or 4 >le write ]
|
||||
[ size-image>> 4 >le write ]
|
||||
[ x-pels>> 4 >le write ]
|
||||
[ y-pels>> 4 >le write ]
|
||||
[ color-used>> 4 >le write ]
|
||||
[ color-important>> 4 >le write ]
|
||||
[ rgb-quads>> write ]
|
||||
[ color-index>> write ]
|
||||
} cleave
|
||||
] with-file-writer ;
|
||||
|
||||
M: bitmap draw-image ( bitmap -- )
|
||||
dup bitmap-height 0 < [
|
||||
dup height>> 0 < [
|
||||
0 0 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
] [
|
||||
0 over bitmap-height abs glRasterPos2i
|
||||
0 over height>> abs glRasterPos2i
|
||||
1.0 1.0 glPixelZoom
|
||||
] if
|
||||
[ bitmap-width ] keep
|
||||
[ width>> ] keep
|
||||
[
|
||||
[ bitmap-height abs ] keep
|
||||
bitmap-bit-count {
|
||||
[ height>> abs ] keep
|
||||
bit-count>> {
|
||||
! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
|
||||
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
|
||||
} case
|
||||
] keep bitmap-array glDrawPixels ;
|
||||
] keep array>> glDrawPixels ;
|
||||
|
||||
M: bitmap width ( bitmap -- ) bitmap-width ;
|
||||
M: bitmap height ( bitmap -- ) bitmap-height ;
|
||||
M: bitmap width ( bitmap -- ) width>> ;
|
||||
M: bitmap height ( bitmap -- ) height>> ;
|
||||
|
||||
: bitmap. ( path -- )
|
||||
load-bitmap <graphics-gadget> gadget. ;
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
|
@ -1,26 +1,21 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays kernel math math.functions namespaces opengl
|
||||
ui.gadgets ui.render ;
|
||||
ui.gadgets ui.render accessors ;
|
||||
IN: graphics.viewer
|
||||
|
||||
TUPLE: graphics-gadget image ;
|
||||
TUPLE: graphics-gadget < gadget image ;
|
||||
|
||||
GENERIC: draw-image ( image -- )
|
||||
GENERIC: width ( image -- w )
|
||||
GENERIC: height ( image -- h )
|
||||
|
||||
M: graphics-gadget pref-dim*
|
||||
graphics-gadget-image
|
||||
[ width ] keep height abs 2array ;
|
||||
image>> [ width ] keep height abs 2array ;
|
||||
|
||||
M: graphics-gadget draw-gadget* ( gadget -- )
|
||||
origin get [
|
||||
graphics-gadget-image draw-image
|
||||
] with-translation ;
|
||||
origin get [ image>> draw-image ] with-translation ;
|
||||
|
||||
: <graphics-gadget> ( bitmap -- gadget )
|
||||
\ graphics-gadget construct-gadget
|
||||
[ set-graphics-gadget-image ] keep ;
|
||||
|
||||
\ graphics-gadget new-gadget
|
||||
swap >>image ;
|
|
@ -20,18 +20,6 @@ IN: vocab-browser
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pprint-class ( class -- )
|
||||
[
|
||||
\ TUPLE: pprint-word dup pprint-word
|
||||
dup superclass tuple eq?
|
||||
[ "<" text dup superclass pprint-word ] unless
|
||||
<block "slots" word-prop [ pprint-slot ] each
|
||||
block> pprint-;
|
||||
]
|
||||
with-pprint nl ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: word-effect-as-string ( word -- string )
|
||||
stack-effect dup
|
||||
[ effect>string ]
|
||||
|
@ -71,10 +59,21 @@ IN: vocab-browser
|
|||
[ drop ]
|
||||
[
|
||||
"Predicate Classes" $heading nl
|
||||
[ pprint-class ] each
|
||||
! [ pprint-class ] each
|
||||
[ { [ ] [ superclass ] } 1arr ] map
|
||||
{ "CLASS" "SUPERCLASS" } prefix
|
||||
print-table
|
||||
]
|
||||
if
|
||||
|
||||
dup vocab words [ class? not ] filter [ symbol? ] filter natural-sort
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[
|
||||
"Symbols" $heading nl
|
||||
print-seq
|
||||
]
|
||||
if
|
||||
|
||||
|
||||
dup vocab words [ generic? ] filter natural-sort
|
||||
dup empty?
|
||||
|
@ -92,6 +91,7 @@ IN: vocab-browser
|
|||
[ builtin-class? not ] filter
|
||||
[ tuple-class? not ] filter
|
||||
[ generic? not ] filter
|
||||
[ symbol? not ] filter
|
||||
[ word? ] filter
|
||||
natural-sort
|
||||
[ [ ] [ word-effect-as-string ] bi 2array ] map
|
||||
|
@ -254,6 +254,40 @@ M: load-this-vocab pprint* ( obj -- )
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: vocab-author pprint* ( vocab-author -- ) [ name>> ] [ ] bi write-object ;
|
||||
|
||||
: $vocab-authors ( seq -- )
|
||||
drop all-authors [ vocab-author boa ] map print-seq ;
|
||||
|
||||
ARTICLE: "vocab-authors" "Vocabulary Authors" { $vocab-authors } ;
|
||||
|
||||
: vocabs-by-author ( author -- vocab-names )
|
||||
authored values concat [ name>> ] map ;
|
||||
|
||||
: $vocabs-by-author ( seq -- )
|
||||
first name>> vocabs-by-author print-these-vocabs ;
|
||||
|
||||
M: vocab-author article-content ( vocab-author -- content )
|
||||
{ $vocabs-by-author } swap suffix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: vocab-tag pprint* ( vocab-tag -- ) [ name>> ] [ ] bi write-object ;
|
||||
|
||||
: print-vocab-tags ( -- ) all-tags [ vocab-tag boa ] map print-seq ;
|
||||
|
||||
: $vocab-tags ( seq -- ) drop print-vocab-tags ;
|
||||
|
||||
ARTICLE: "vocab-tags" "Vocabulary Tags" { $vocab-tags } ;
|
||||
|
||||
: $vocabs-with-tag ( seq -- )
|
||||
first tagged values concat [ name>> ] map print-these-vocabs ;
|
||||
|
||||
M: vocab-tag article-content ( vocab-tag -- content )
|
||||
name>> { $vocabs-with-tag } swap suffix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "vocab-index-all" "All Vocabularies" { $all-vocabs } ;
|
||||
ARTICLE: "vocab-index-loaded" "Loaded Vocabularies" { $loaded-vocabs } ;
|
||||
ARTICLE: "vocab-index-unloaded" "Unloaded Vocabularies" { $loaded-vocabs } ;
|
||||
|
@ -268,4 +302,9 @@ ARTICLE: "vocab-indices" "Vocabulary Indices"
|
|||
{ $subsection "vocab-index-extra" }
|
||||
{ $subsection "vocab-index-all" }
|
||||
{ $subsection "vocab-index-loaded" }
|
||||
{ $subsection "vocab-index-unloaded" } ;
|
||||
{ $subsection "vocab-index-unloaded" }
|
||||
{ $subsection "vocab-authors" }
|
||||
{ $subsection "vocab-tags" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|