steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-08-27 19:23:20 -05:00
parent 7771c55cb5 6760d44468
commit 367f024a1b
11 changed files with 280 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/cocoa/application/application.factor
View File

@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
: NSApp ( -- app ) NSApplication -> sharedApplication ;
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -780,6 +780,10 @@ M: f whatever2 ; inline
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
SYMBOL: not-an-assoc
[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test

14
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -207,12 +207,14 @@ CONSTANT: lookup-table-at-max 256
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
dup assoc? [
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
] [ drop f ] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -211,7 +211,7 @@ CLASS: {
{ +name+ "FactorApplicationDelegate" }
}
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
[ 3drop reset-run-loop ]
} ;

6
core/classes/algebra/algebra-tests.factor
View File

@ -2,8 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random stack-checker effects kernel.private sbufs math.order
vectors source-files compiler.units growable random
stack-checker effects kernel.private sbufs math.order
classes.tuple accessors ;
IN: classes.algebra.tests
@ -317,4 +317,4 @@ SINGLETON: sc
! UNION: u1 sa sb ;
! UNION: u2 sc ;
! [ f ] [ u1 u2 classes-intersect? ] unit-test
! [ f ] [ u1 u2 classes-intersect? ] unit-test

2
core/classes/classes-tests.factor
View File

@ -2,7 +2,7 @@ USING: alien arrays generic assocs hashtables io
io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files compiler.units
classes.algebra definitions source-files compiler.units
kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests

5
core/classes/union/union-tests.factor
View File

@ -2,9 +2,8 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string
eval see ;
classes.algebra source-files compiler.units kernel.private
sorting vocabs io.streams.string eval see ;
IN: classes.union.tests
! DEFER: bah

6
core/words/words-docs.factor
View File

@ -219,7 +219,11 @@ HELP: <word> ( name vocab -- word )
HELP: gensym
{ $values { "word" word } }
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $examples { $example "USING: prettyprint words ;"
"gensym ."
"( gensym )"
}
}
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
HELP: bootstrapping?

8
extra/bloom-filters/bloom-filters-tests.factor
View File

@ -66,7 +66,8 @@ IN: bloom-filters.tests
[ t ] [ 2000 iota
full-bloom-filter
[ bloom-filter-member? ] curry map
[ ] all? ] unit-test
[ ] all?
] unit-test
! We shouldn't have more than 0.01 false-positive rate.
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
@ -74,5 +75,6 @@ IN: bloom-filters.tests
[ bloom-filter-member? ] curry map
[ ] filter
! TODO: This should be 10, but the false positive rate is currently very
! high. It shouldn't be much more than this.
length 150 <= ] unit-test
! high. 300 is large enough not to prevent builds from succeeding.
length 300 <=
] unit-test

232
extra/images/gif/gif.factor Normal file
View File

@ -0,0 +1,232 @@
! Copyrigt (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators constructors destructors
images images.loader io io.binary io.buffers
io.encodings.binary io.encodings.string io.encodings.utf8
io.files io.files.info io.ports io.streams.limited kernel make
math math.bitwise math.functions multiline namespaces
prettyprint sequences ;
IN: images.gif
SINGLETON: gif-image
"gif" gif-image register-image-class
TUPLE: loading-gif
loading?
magic
width height
flags
background-color
default-aspect-ratio
global-color-table
graphic-control-extensions
application-extensions
plain-text-extensions
comment-extensions
image-descriptor
local-color-table
compressed-bytes ;
TUPLE: gif-frame
image-descriptor
local-color-table ;
ERROR: unsupported-gif-format magic ;
ERROR: unknown-extension n ;
ERROR: gif-unexpected-eof ;
TUPLE: graphics-control-extension
label block-size raw-data
packed delay-time color-index
block-terminator ;
TUPLE: image-descriptor
separator left top width height flags ;
TUPLE: plain-text-extension
introducer label block-size text-grid-left text-grid-top text-grid-width
text-grid-height cell-width cell-height
text-fg-color-index text-bg-color-index plain-text-data ;
TUPLE: application-extension
introducer label block-size identifier authentication-code
application-data ;
TUPLE: comment-extension
introducer label comment-data ;
TUPLE: trailer byte ;
CONSTRUCTOR: trailer ( byte -- obj ) ;
CONSTANT: image-descriptor HEX: 2c
! Extensions
CONSTANT: extension-identifier HEX: 21
CONSTANT: plain-text-extension HEX: 01
CONSTANT: graphic-control-extension HEX: f9
CONSTANT: comment-extension HEX: fe
CONSTANT: application-extension HEX: ff
CONSTANT: trailer HEX: 3b
: <loading-gif> ( -- loading-gif )
\ loading-gif new
V{ } clone >>graphic-control-extensions
V{ } clone >>application-extensions
V{ } clone >>plain-text-extensions
V{ } clone >>comment-extensions
t >>loading? ;
GENERIC: stream-peek1 ( stream -- byte )
M: input-port stream-peek1
dup check-disposed dup wait-to-read
[ drop f ] [ buffer>> buffer-peek ] if ; inline
: peek1 ( -- byte ) input-stream get stream-peek1 ;
: (read-sub-blocks) ( -- )
read1 [ read , (read-sub-blocks) ] unless-zero ;
: read-sub-blocks ( -- bytes )
[ (read-sub-blocks) ] { } make B{ } concat-as ;
: read-image-descriptor ( -- image-descriptor )
\ image-descriptor new
1 read le> >>separator
2 read le> >>left
2 read le> >>top
2 read le> >>width
2 read le> >>height
1 read le> >>flags ;
: read-graphic-control-extension ( -- graphic-control-extension )
\ graphics-control-extension new
1 read le> [ >>block-size ] [ read ] bi
>>raw-data
1 read le> >>block-terminator ;
: read-plain-text-extension ( -- plain-text-extension )
\ plain-text-extension new
1 read le> >>block-size
2 read le> >>text-grid-left
2 read le> >>text-grid-top
2 read le> >>text-grid-width
2 read le> >>text-grid-height
1 read le> >>cell-width
1 read le> >>cell-height
1 read le> >>text-fg-color-index
1 read le> >>text-bg-color-index
read-sub-blocks >>plain-text-data ;
: read-comment-extension ( -- comment-extension )
\ comment-extension new
read-sub-blocks >>comment-data ;
: read-application-extension ( -- read-application-extension )
\ application-extension new
1 read le> >>block-size
8 read utf8 decode >>identifier
3 read >>authentication-code
read-sub-blocks >>application-data ;
: read-gif-header ( loading-gif -- loading-gif )
6 read utf8 decode >>magic ;
ERROR: unimplemented message ;
: read-GIF87a ( loading-gif -- loading-gif )
"GIF87a" unimplemented ;
: read-logical-screen-descriptor ( loading-gif -- loading-gif )
2 read le> >>width
2 read le> >>height
1 read le> >>flags
1 read le> >>background-color
1 read le> >>default-aspect-ratio ;
: color-table? ( image -- ? ) flags>> 7 bit? ; inline
: interlaced? ( image -- ? ) flags>> 6 bit? ; inline
: sort? ( image -- ? ) flags>> 5 bit? ; inline
: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
: read-global-color-table ( loading-gif -- loading-gif )
dup color-table? [
dup color-table-size read >>global-color-table
] when ;
: maybe-read-local-color-table ( loading-gif -- loading-gif )
dup image-descriptor>> color-table? [
dup color-table-size read >>local-color-table
] when ;
: read-image-data ( loading-gif -- loading-gif )
read-sub-blocks >>compressed-bytes ;
: read-table-based-image ( loading-gif -- loading-gif )
read-image-descriptor >>image-descriptor
maybe-read-local-color-table
read-image-data ;
: read-graphic-rendering-block ( loading-gif -- loading-gif )
read-table-based-image ;
: read-extension ( loading-gif -- loading-gif )
read1 {
{ plain-text-extension [
read-plain-text-extension over plain-text-extensions>> push
] }
{ graphic-control-extension [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
{ comment-extension [
read-comment-extension over comment-extensions>> push
] }
{ application-extension [
read-application-extension over application-extensions>> push
] }
{ f [ gif-unexpected-eof ] }
[ unknown-extension ]
} case ;
ERROR: unhandled-data byte ;
: read-data ( loading-gif -- loading-gif )
read1 {
{ extension-identifier [ read-extension ] }
{ graphic-control-extension [
read-graphic-control-extension
over graphic-control-extensions>> push
] }
{ image-descriptor [ read-table-based-image ] }
{ trailer [ f >>loading? ] }
[ unhandled-data ]
} case ;
: read-GIF89a ( loading-gif -- loading-gif )
read-logical-screen-descriptor
read-global-color-table
[ read-data dup loading?>> ] loop ;
: load-gif ( stream -- loading-gif )
[
<loading-gif>
read-gif-header dup magic>> {
{ "GIF87a" [ read-GIF87a ] }
{ "GIF89a" [ read-GIF89a ] }
[ unsupported-gif-format ]
} case
] with-input-stream ;
: loading-gif>image ( loading-gif -- image )
;
ERROR: loading-gif-error gif-image ;
: ensure-loaded ( gif-image -- gif-image )
dup loading?>> [ loading-gif-error ] when ;
M: gif-image stream>image ( path gif-image -- image )
drop load-gif ensure-loaded loading-gif>image ;

22
extra/images/viewer/viewer.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ui.images ;
USING: accessors images images.loader io.pathnames kernel
models namespaces opengl opengl.gl opengl.textures sequences
strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
constructors ;
IN: images.viewer
TUPLE: image-gadget < gadget image texture ;
@ -13,7 +14,20 @@ M: image-gadget pref-dim* image>> dim>> ;
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
dup image>> [
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
] [
drop
] if ;
TUPLE: image-control < image-gadget ;
CONSTRUCTOR: image-control ( model -- image-control ) ;
M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
M: image-control model-changed
swap value>> >>image relayout ;
! Todo: delete texture on ungraft