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

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

db4
Slava Pestov 2009-04-03 10:25:56 -05:00
parent f7ba7b4bfa 5a6bcbb231
commit 92cc670c28
38 changed files with 1718 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.txt
View File

@ -113,12 +113,6 @@ the command prompt using the console application:
factor.com -i=boot.<cpu>.image
Before bootstrapping, you will need to download the DLLs for the Pango
text rendering library. The required DLLs are listed in
build-support/dlls.txt and are available from the following location:
<http://factorcode.org/dlls>
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.

6
basis/alien/destructors/destructors.factor Normal file → Executable file
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors destructors accessors kernel parser words ;
USING: functors destructors accessors kernel parser words
effects generalizations sequences ;
IN: alien.destructors
SLOT: alien
@ -11,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}
N [ F stack-effect out>> length ]
WHERE
@ -18,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
M: F-destructor dispose* alien>> F ;
M: F-destructor dispose* alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline

3
basis/combinators/smart/smart.factor
View File

@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order
stack-checker math ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
dup infer out>> '[ @ _ ndrop ] ;
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;

6
basis/images/images.factor Normal file → Executable file
View File

@ -1,11 +1,13 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel ;
USING: combinators kernel accessors ;
IN: images
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image )

12
basis/images/normalization/normalization.factor Normal file → Executable file
View File

@ -61,6 +61,18 @@ M: ARGB normalize-component-order*
M: ABGR normalize-component-order*
drop ARGB>RGBA BGRA>RGBA ;
: fix-XBGR ( bitmap -- bitmap' )
dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
M: XBGR normalize-component-order*
drop fix-XBGR ABGR normalize-component-order* ;
: fix-BGRX ( bitmap -- bitmap' )
dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
M: BGRX normalize-component-order*
drop fix-BGRX BGRA normalize-component-order* ;
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[

61
basis/opengl/textures/textures.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: accessors assocs cache colors.constants destructors fry kernel
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float locals sequences math math.vectors
math.matrices generalizations fry columns ;
math.matrices generalizations fry columns arrays ;
IN: opengl.textures
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@ -17,6 +17,7 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
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 ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
GENERIC: draw-texture ( texture -- )
@ -24,7 +25,7 @@ GENERIC: draw-scaled-texture ( dim texture -- )
<PRIVATE
TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
@ -44,7 +45,7 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
tri * group ; inline
: power-of-2-image ( image -- image )
dup dim>> [ 0 = ] all? [
dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
clone dup
[ image-rows ]
[ dim>> [ next-power-of-2 ] map ]
@ -92,26 +93,30 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
: draw-textured-rect ( dim texture -- )
[
(draw-textured-rect)
GL_TEXTURE_2D 0 glBindTexture
[ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
[ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
[ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
tri
] with-texturing ;
: texture-coords ( dim -- coords )
[ dup next-power-of-2 /f ] map
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
: texture-coords ( texture -- coords )
[
[ dim>> ] [ image>> dim>> ] bi v/
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
[ v* ] with map
] keep
image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
float-array{ } join ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
: <single-texture> ( image loc -- texture )
single-texture new swap >>loc
swap
[ dim>> >>dim ] keep
[ dim>> product 0 = ] keep '[
_
[ dim>> texture-coords >>texture-coords ]
[ power-of-2-image make-texture >>texture ] bi
: <single-texture> ( image loc dim -- texture )
[ power-of-2-image ] 2dip
single-texture new swap >>dim swap >>loc swap >>image
dup image>> dim>> product 0 = [
dup texture-coords >>texture-coords
dup image>> make-texture >>texture
dup make-texture-display-list >>display-list
] unless ;
@ -133,19 +138,20 @@ TUPLE: multi-texture grid display-list loc disposed ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
'[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
: grid-has-alpha? ( grid -- ? )
first first image>> has-alpha? ;
: make-textured-grid-display-list ( grid -- dlist )
GL_COMPILE [
[
[
[
[ dim>> ] keep (draw-textured-rect)
] each
] each
[ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
[ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
[ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
GL_TEXTURE_2D 0 glBindTexture
] with-texturing
] make-dlist ;
@ -163,11 +169,14 @@ M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
CONSTANT: max-texture-size { 256 256 }
CONSTANT: max-texture-size { 512 512 }
PRIVATE>
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
: small-texture? ( dim -- ? )
max-texture-size [ <= ] 2all? ;
: <texture> ( image loc dim -- texture )
pick dim>> small-texture?
[ <single-texture> ]
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
[ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;

3
basis/tools/deploy/shaker/shaker.factor
View File

@ -157,7 +157,8 @@ IN: tools.deploy.shaker
"specializer"
"step-into"
"step-into?"
"superclass"
! UI needs this
! "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"

9
basis/tools/deploy/windows/windows.factor
View File

@ -9,11 +9,6 @@ IN: tools.deploy.windows
: copy-dll ( bundle-name -- )
"resource:factor.dll" swap copy-file-into ;
: copy-pango ( bundle-name -- )
"resource:build-support/dlls.txt" ascii file-lines
[ "resource:" prepend-path ] map
swap copy-files-into ;
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
@ -22,9 +17,7 @@ IN: tools.deploy.windows
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
deploy-ui? get [
[ copy-pango ]
[ "" copy-theme ]
[ ".exe" copy-vm ] tri
[ "" copy-theme ] [ ".exe" copy-vm ] bi
] [ ".com" copy-vm ] if ;
M: winnt deploy*

57
basis/ui/backend/windows/windows.factor
View File

@ -1,16 +1,16 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.private ui.gadgets ui.gadgets.private ui.backend
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators fry combinators.short-circuit
continuations command-line shuffle opengl ui.render ascii
math.bitwise locals accessors math.rectangles math.order ascii
calendar io.encodings.utf16n ;
USING: alien alien.c-types alien.strings arrays assocs ui ui.private
ui.gadgets ui.gadgets.private ui.backend ui.clipboards
ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
math.vectors namespaces make sequences strings vectors words
windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
windows.messages windows.types windows.offscreen windows.nt windows
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
io.encodings.utf16n ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
@ -433,12 +433,7 @@ M: windows-ui-backend do-events
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
[ window-loc>> dup ] [ dim>> ] bi v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
[ window-loc>> ] [ dim>> ] bi <RECT> ;
: default-position-RECT ( RECT -- )
dup get-RECT-dimensions [ 2drop ] 2dip
@ -501,35 +496,12 @@ M: windows-ui-backend (open-window) ( world -- )
hWnd>> show-window ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
f CreateCompatibleDC
dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
[ f 0 CreateDIBSection ] keep *void*
[ 2dup SelectObject drop ] dip ;
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
@ -548,13 +520,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
! each pixel; it's left as zero
: (make-opaque) ( byte-array -- byte-array' )
[ length 4 / ]
[ length 4 /i ]
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
[ ] tri ;
: (opaque-pixels) ( world -- pixels )
[ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
memory>byte-array (make-opaque) ;
[ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
[ (opaque-pixels) ] [ dim>> first2 ] bi ;

2
basis/ui/images/images.factor Normal file → Executable file
View File

@ -20,7 +20,7 @@ PRIVATE>
: rendered-image ( path -- texture )
world get image-texture-cache
[ cached-image { 0 0 } <texture> ] cache ;
[ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
: draw-image ( image-name -- )
rendered-image draw-texture ;

11
basis/ui/text/core-text/core-text.factor Normal file → Executable file
View File

@ -10,9 +10,6 @@ IN: ui.text.core-text
SINGLETON: core-text-renderer
M: core-text-renderer init-text-rendering
<cache-assoc> >>text-handle drop ;
M: core-text-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-line dim>> ]
@ -22,9 +19,11 @@ M: core-text-renderer flush-layout-cache
cached-lines get purge-cache ;
: rendered-line ( font string -- texture )
world get world-text-handle
[ cached-line [ image>> ] [ loc>> ] bi <texture> ]
2cache ;
world get world-text-handle [
cached-line
[ image>> ] [ loc>> ] [ image>> dim>> ] tri
<texture>
] 2cache ;
M: core-text-renderer draw-string ( font string -- )
rendered-line draw-texture ;

11
basis/ui/text/pango/pango.factor
View File

@ -7,9 +7,6 @@ IN: ui.text.pango
SINGLETON: pango-renderer
M: pango-renderer init-text-rendering
<cache-assoc> >>text-handle drop ;
M: pango-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
@ -18,9 +15,11 @@ M: pango-renderer flush-layout-cache
cached-layouts get purge-cache ;
: rendered-layout ( font string -- texture )
world get world-text-handle
[ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
2cache ;
world get world-text-handle [
cached-layout
[ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
<texture>
] 2cache ;
M: pango-renderer draw-string ( font string -- )
rendered-layout draw-texture ;

1
basis/ui/text/pango/summary.txt Executable file
View File

@ -0,0 +1 @@
UI text rendering implementation using cross-platform Pango library

20
basis/ui/text/text-tests.factor Normal file → Executable file
View File

@ -1,6 +1,22 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test ui.text fonts ;
USING: tools.test ui.text fonts math accessors kernel sequences ;
IN: ui.text.tests
[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
[ t ] [
sans-serif-font "aaa" line-metrics
[ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
] unit-test
[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test

11
basis/ui/text/text.factor Normal file → Executable file
View File

@ -1,17 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.order opengl opengl.gl
strings fonts colors accessors namespaces ui.gadgets.worlds ;
USING: kernel arrays sequences math math.order cache opengl
opengl.gl strings fonts colors accessors namespaces
ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
SYMBOL: font-renderer
HOOK: init-text-rendering font-renderer ( world -- )
: world-text-handle ( world -- handle )
dup text-handle>> [ dup init-text-rendering ] unless
dup text-handle>> [ <cache-assoc> >>text-handle ] unless
text-handle>> ;
HOOK: flush-layout-cache font-renderer ( -- )
@ -79,7 +78,7 @@ USING: vocabs.loader namespaces system combinators ;
"ui-backend" get [
{
{ [ os macosx? ] [ "core-text" ] }
{ [ os windows? ] [ "pango" ] }
{ [ os windows? ] [ "uniscribe" ] }
{ [ os unix? ] [ "pango" ] }
} cond
] unless* "ui.text." prepend require

1
basis/ui/text/uniscribe/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/ui/text/uniscribe/summary.txt Executable file
View File

@ -0,0 +1 @@
UI text rendering implementation using the MS Windows Uniscribe library

1
basis/ui/text/uniscribe/tags.txt Executable file
View File

@ -0,0 +1 @@
unportable

42
basis/ui/text/uniscribe/uniscribe.factor Executable file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache kernel math math.vectors sequences fonts
namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds
windows.uniscribe ;
IN: ui.text.uniscribe
SINGLETON: uniscribe-renderer
M: uniscribe-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-script-string size>> ] if-empty ;
M: uniscribe-renderer flush-layout-cache
cached-script-strings get purge-cache ;
: rendered-script-string ( font string -- texture )
world get world-text-handle
[ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
2cache ;
M: uniscribe-renderer draw-string ( font string -- )
dup dup selection? [ string>> ] when empty?
[ 2drop ] [ rendered-script-string draw-texture ] if ;
M: uniscribe-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [
cached-script-string x>line-offset 0 = [ 1+ ] unless
] if-empty ;
M: uniscribe-renderer offset>x ( n font string -- x )
[ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
M: uniscribe-renderer font-metrics ( font -- metrics )
" " cached-script-string metrics>> clone f >>width ;
M: uniscribe-renderer line-metrics ( font string -- metrics )
[ " " line-metrics clone 0 >>width ]
[ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
if-empty ;
uniscribe-renderer font-renderer set-global

37
basis/windows/fonts/fonts.factor Executable file
View File

@ -0,0 +1,37 @@
USING: assocs memoize locals kernel accessors init fonts math
combinators windows windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
} at-default ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! nHeight
0 0 0 ! nWidth, nEscapement, nOrientation
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
font italic?>> TRUE FALSE ? ! fdwItalic
FALSE ! fdwUnderline
FALSE ! fdWStrikeOut
DEFAULT_CHARSET ! fdwCharSet
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
DEFAULT_QUALITY ! fdwQuality
DEFAULT_PITCH ! fdwPitchAndFamily
font name>> windows-font-name
CreateFont
dup win32-error=0/f ;
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
[ metrics new 0 >>width ] dip {
[ TEXTMETRICW-tmHeight >>height ]
[ TEXTMETRICW-tmAscent >>ascent ]
[ TEXTMETRICW-tmDescent >>descent ]
} cleave ;

1320
basis/windows/gdi32/gdi32.factor
View File

File diff suppressed because it is too large Load Diff

1
basis/windows/offscreen/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

5
basis/windows/offscreen/offscreen-tests.factor Executable file
View File

@ -0,0 +1,5 @@
IN: windows.offscreen.tests
USING: windows.offscreen effects tools.test kernel images ;
{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as
[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test

53
basis/windows/offscreen/offscreen.factor Executable file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2009 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel combinators sequences
math windows.gdi32 windows.types images destructors
accessors fry locals ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
: make-bitmap ( dim dc -- hBitmap bits )
[ nip ]
[
swap (bitmap-info) DIB_RGB_COLORS f <void*>
[ f 0 CreateDIBSection ] keep *void*
] 2bi
[ [ SelectObject drop ] keep ] dip ;
: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
[ f CreateCompatibleDC ] dip over make-bitmap ;
: bitmap>byte-array ( bits dim -- byte-array )
product 4 * memory>byte-array ;
: bitmap>image ( bits dim -- image )
[ bitmap>byte-array ] keep
<image>
swap >>dim
swap >>bitmap
BGRX >>component-order
t >>upside-down? ;
: with-memory-dc ( quot: ( hDC -- ) -- )
[ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
:: make-bitmap-image ( dim dc quot -- image )
dim dc make-bitmap [ &DeleteObject drop ] dip
quot dip
dim bitmap>image ; inline

1
basis/windows/offscreen/summary.txt Executable file
View File

@ -0,0 +1 @@
Utility words for memory DCs and bitmaps

1
basis/windows/offscreen/tags.txt Executable file
View File

@ -0,0 +1 @@
unportable

64
basis/windows/types/types.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax namespaces kernel words ;
USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors ;
IN: windows.types
TYPEDEF: char CHAR
@ -244,14 +245,14 @@ C-STRUCT: RECT
{ "LONG" "right" }
{ "LONG" "bottom" } ;
! C-STRUCT: PAINTSTRUCT
! { "HDC" " hdc" }
! { "BOOL" "fErase" }
! { "RECT" "rcPaint" }
! { "BOOL" "fRestore" }
! { "BOOL" "fIncUpdate" }
! { "BYTE[32]" "rgbReserved" }
! ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
{ "BOOL" "fErase" }
{ "RECT" "rcPaint" }
{ "BOOL" "fRestore" }
{ "BOOL" "fIncUpdate" }
{ "BYTE[32]" "rgbReserved" }
;
C-STRUCT: BITMAPINFOHEADER
{ "DWORD" "biSize" }
@ -283,6 +284,10 @@ C-STRUCT: POINT
{ "LONG" "x" }
{ "LONG" "y" } ;
C-STRUCT: SIZE
{ "LONG" "cx" }
{ "LONG" "cy" } ;
C-STRUCT: MSG
{ "HWND" "hWnd" }
{ "UINT" "message" }
@ -327,6 +332,14 @@ C-STRUCT: RECT
{ "LONG" "right" }
{ "LONG" "bottom" } ;
: <RECT> ( loc dim -- RECT )
over v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
@ -363,3 +376,36 @@ C-STRUCT: ACCEL
{ "WORD" "key" }
{ "WORD" "cmd" } ;
TYPEDEF: ACCEL* LPACCEL
TYPEDEF: DWORD COLORREF
TYPEDEF: DWORD* LPCOLORREF
: RGB ( r g b -- COLORREF )
{ 16 8 0 } bitfield ; inline
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
C-STRUCT: TEXTMETRICW
{ "LONG" "tmHeight" }
{ "LONG" "tmAscent" }
{ "LONG" "tmDescent" }
{ "LONG" "tmInternalLeading" }
{ "LONG" "tmExternalLeading" }
{ "LONG" "tmAveCharWidth" }
{ "LONG" "tmMaxCharWidth" }
{ "LONG" "tmWeight" }
{ "LONG" "tmOverhang" }
{ "LONG" "tmDigitizedAspectX" }
{ "LONG" "tmDigitizedAspectY" }
{ "WCHAR" "tmFirstChar" }
{ "WCHAR" "tmLastChar" }
{ "WCHAR" "tmDefaultChar" }
{ "WCHAR" "tmBreakChar" }
{ "BYTE" "tmItalic" }
{ "BYTE" "tmUnderlined" }
{ "BYTE" "tmStruckOut" }
{ "BYTE" "tmPitchAndFamily" }
{ "BYTE" "tmCharSet" } ;
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC

1
basis/windows/uniscribe/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/windows/uniscribe/summary.txt Executable file
View File

@ -0,0 +1 @@
High-level wrapper around Uniscribe binding

1
basis/windows/uniscribe/tags.txt Executable file
View File

@ -0,0 +1 @@
unportable

118
basis/windows/uniscribe/uniscribe.factor Executable file
View File

@ -0,0 +1,118 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
io.encodings.utf16n accessors arrays combinators destructors locals
cache namespaces init images.normalization fonts alien.c-types
windows windows.usp10 windows.offscreen windows.gdi32
windows.ole32 windows.types windows.fonts opengl.textures ;
IN: windows.uniscribe
TUPLE: script-string font string metrics ssa size image disposed ;
: line-offset>x ( n script-string -- x )
2dup string>> length = [
ssa>> ! ssa
swap 1- ! icp
TRUE ! fTrailing
] [
ssa>>
swap ! icp
FALSE ! fTrailing
] if
0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
0 <int> ! pCh
0 <int> ! piTrailing
[ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
<PRIVATE
: make-script-string ( dc string -- script-string )
dup selection? [ string>> ] when
[ utf16n encode ] ! pString
[ length ] bi ! cString
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
-1 ! iCharset -- Unicode
SSA_GLYPHS ! dwFlags
0 ! iReqWidth
f ! psControl
f ! psState
f ! piDx
f ! pTabdef
f ! pbInClass
f <void*> ! pssa
[ ScriptStringAnalyse ] keep
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
: set-dc-colors ( dc font -- )
[ background>> color>RGB SetBkColor drop ]
[ foreground>> color>RGB SetTextColor drop ] 2bi ;
: selection-start/end ( script-string -- iMinSel iMaxSel )
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
: (draw-script-string) ( script-string -- )
[
ssa>> ! ssa
0 ! iX
0 ! iY
0 ! uOptions
f ! prc
]
[ selection-start/end ] bi
! iMinSel
! iMaxSel
FALSE ! fDisabled
ScriptStringOut ole32-error ;
: draw-script-string ( dc script-string -- )
[ font>> set-dc-colors ] keep (draw-script-string) ;
: script-string-bitmap-size ( script-string -- dim )
size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
:: make-script-string-image ( dc script-string -- image )
script-string script-string-bitmap-size dc
[ dc script-string draw-script-string ] make-bitmap-image ;
: set-dc-font ( dc font -- )
cache-font SelectObject win32-error=0/f ;
: script-string-size ( script-string -- dim )
ssa>> ScriptString_pSize
dup win32-error=0/f
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
: dc-metrics ( dc -- metrics )
"TEXTMETRICW" <c-object>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
: <script-string> ( font string -- script-string )
[ script-string new ] 2dip
[ >>font ] [ >>string ] bi*
[
{
[ over font>> set-dc-font ]
[ dc-metrics >>metrics ]
[ over string>> make-script-string >>ssa ]
[ drop dup script-string-size >>size ]
[ over make-script-string-image >>image ]
} cleave
] with-memory-dc ;
PRIVATE>
M: script-string dispose*
ssa>> <void*> ScriptStringFree ole32-error ;
SYMBOL: cached-script-strings
: cached-script-string ( string font -- script-string )
cached-script-strings get-global [ <script-string> ] 2cache ;
[ <cache-assoc> cached-script-strings set-global ]
"windows.uniscribe" add-init-hook

4
basis/windows/usp10/usp10.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax alien.destructors ;
IN: windows.usp10
LIBRARY: usp10
@ -262,6 +262,8 @@ FUNCTION: HRESULT ScriptStringFree (
SCRIPT_STRING_ANALYSIS* pssa
) ;
DESTRUCTOR: ScriptStringFree
FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;

2
basis/windows/windows.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types alien.strings arrays
combinators kernel math namespaces parser prettyprint sequences
combinators kernel math namespaces parser sequences
windows.errors windows.types windows.kernel32 words
io.encodings.utf16n ;
IN: windows

12
build-support/dlls.txt
View File

@ -1,12 +0,0 @@
libcairo-2.dll
libgio-2.0-0.dll
libglib-2.0-0.dll
libgmodule-2.0-0.dll
libgobject-2.0-0.dll
libgthread-2.0-0.dll
libpango-1.0-0.dll
libpangocairo-1.0-0.dll
libpangowin32-1.0-0.dll
libpng12-0.dll
libtiff3.dll
zlib1.dll

12
build-support/factor.sh
View File

@ -445,16 +445,6 @@ get_url() {
check_ret $DOWNLOADER
}
maybe_download_dlls() {
if [[ $OS == winnt ]] ; then
for file in `cat build-support/dlls.txt`; do
get_url http://factorcode.org/dlls/$file
chmod 777 *.dll
check_ret chmod
done
fi
}
get_config_info() {
find_build_info
check_installed_programs
@ -472,7 +462,6 @@ install() {
cd_factor
make_factor
get_boot_image
maybe_download_dlls
bootstrap
}
@ -547,7 +536,6 @@ case "$1" in
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
report) find_build_info ;;
dlls) get_config_info; maybe_download_dlls;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
*) usage ;;

14
extra/mason/child/child.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators.short-circuit
continuations debugger http.client io.directories io.files io.launcher
continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
mason.platform mason.report mason.email namespaces sequences ;
IN: mason.child
@ -9,20 +9,8 @@ IN: mason.child
: make-cmd ( -- args )
gnu-make platform 2array ;
: dll-url ( -- url )
"http://factorcode.org/dlls/"
target-cpu get "x86.64" = [ "64/" append ] when ;
: download-dlls ( -- )
target-os get "winnt" = [
dll-url "build-support/dlls.txt" ascii file-lines
[ append download ] with each
] when ;
: make-vm ( -- )
"factor" [
download-dlls
<process>
make-cmd >>command
"../compile-log" >>stdout

4
extra/ui/offscreen/offscreen.factor
View File

@ -1,7 +1,7 @@
! (c) 2008 Joe Groff, see license for details
USING: accessors continuations images.bitmap kernel math
sequences ui.gadgets ui.gadgets.worlds ui ui.backend
destructors ;
sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.private ui ui.backend destructors ;
IN: ui.offscreen
TUPLE: offscreen-world < world ;

1
extra/ui/offscreen/tags.txt
View File

@ -1,3 +1,2 @@
unportable
ui
graphics