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

db4
Daniel Ehrenberg 2009-01-14 10:43:06 -06:00
commit bd9a8472f7
41 changed files with 414 additions and 920 deletions

View File

@ -2,6 +2,4 @@ USING: vocabs vocabs.loader kernel ;
"math.ratios" require "math.ratios" require
"math.floats" require "math.floats" require
"math.complex" require "math.complex" require
"prettyprint" vocab [ "math.complex.prettyprint" require ] when

View File

@ -15,7 +15,7 @@ IN: io.files.windows
CreateFile-flags f CreateFile opened-file CreateFile-flags f CreateFile opened-file
] with-destructors ; ] with-destructors ;
: open-pipe-r/w ( path -- win32-file ) : open-r/w ( path -- win32-file )
{ GENERIC_READ GENERIC_WRITE } flags { GENERIC_READ GENERIC_WRITE } flags
OPEN_EXISTING 0 open-file ; OPEN_EXISTING 0 open-file ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private USING: accessors kernel kernel.private math math.private
math.libm math.functions arrays math.functions.private sequences math.libm math.functions arrays math.functions.private sequences
@ -47,3 +47,9 @@ M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
IN: syntax IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing : C{ \ } [ first2 rect> ] parse-literal ; parsing
USE: prettyprint.custom
M: complex pprint* pprint-object ;
M: complex pprint-delims drop \ C{ \ } ;
M: complex >pprint-sequence >rect 2array ;

View File

@ -1,8 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.functions arrays prettyprint.custom kernel ;
IN: math.complex.prettyprint
M: complex pprint* pprint-object ;
M: complex pprint-delims drop \ C{ \ } ;
M: complex >pprint-sequence >rect 2array ;

View File

@ -3,17 +3,8 @@ USING: tools.test system io.pathnames io.files io.files.info
io.files.temp kernel tools.deploy.config io.files.temp kernel tools.deploy.config
tools.deploy.config.editor tools.deploy.backend math sequences tools.deploy.config.editor tools.deploy.backend math sequences
io.launcher arrays namespaces continuations layouts accessors io.launcher arrays namespaces continuations layouts accessors
io.encodings.ascii urls math.parser io.directories ; io.encodings.ascii urls math.parser io.directories
tools.deploy.test ;
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
"resource:" [
[ vm "test.image" temp-file ] dip
dup deploy-config make-deploy-image
] with-directory ;
: small-enough? ( n -- ? )
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test [ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
@ -36,11 +27,6 @@ os macosx? [
[ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
] when ] when
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
2array try-process ;
{ {
"tools.deploy.test.1" "tools.deploy.test.1"
"tools.deploy.test.2" "tools.deploy.test.2"
@ -113,3 +99,8 @@ M: quit-responder call-responder*
"tools.deploy.test.9" shake-and-bake "tools.deploy.test.9" shake-and-bake
run-temp-image run-temp-image
] unit-test ] unit-test
[ ] [
"tools.deploy.test.10" shake-and-bake
run-temp-image
] unit-test

View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.deploy.test.10 ;
IN: tools.deploy.test.10.tests

View File

@ -0,0 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: prettyprint ;
IN: tools.deploy.test.10
: main ( -- ) C{ 0 1 } pprint ;
MAIN: main

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-reflection 3 }
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ deploy-compiler? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-ui? f }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.10" }
}

View File

@ -0,0 +1,19 @@
USING: accessors arrays continuations io.directories io.files.info
io.files.temp io.launcher kernel layouts math sequences system
tools.deploy.backend tools.deploy.config.editor ;
IN: tools.deploy.test
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
"resource:" [
[ vm "test.image" temp-file ] dip
dup deploy-config make-deploy-image
] with-directory ;
: small-enough? ( n -- ? )
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
2array try-process ;

View File

@ -28,7 +28,7 @@ IN: ui.gadgets.scrollers.tests
"v" get [ "v" get [
[ { 10 20 } ] [ "v" get model>> range-value ] unit-test [ { 10 20 } ] [ "v" get model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg viewport-gap v+ scroller-border v+ ] unit-test
] with-grafted-gadget ] with-grafted-gadget
[ ] [ [ ] [
@ -43,13 +43,13 @@ IN: ui.gadgets.scrollers.tests
"s" get [ "s" get [
[ { 34 34 } ] [ "s" get viewport>> rect-dim ] unit-test [ { 34 34 } ] [ "s" get viewport>> rect-dim ] unit-test
[ { 106 106 } ] [ "s" get viewport>> viewport-dim ] unit-test [ { 107 107 } ] [ "s" get viewport>> viewport-dim ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test [ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
[ { 106 106 } ] [ "s" get model>> range-max-value ] unit-test [ { 107 107 } ] [ "s" get model>> range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test [ ] [ { 10 20 } "s" get scroll ] unit-test
@ -57,7 +57,7 @@ IN: ui.gadgets.scrollers.tests
[ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test [ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg viewport-gap v+ scroller-border v+ ] unit-test
] with-grafted-gadget ] with-grafted-gadget
<gadget> { 600 400 } >>dim "g1" set <gadget> { 600 400 } >>dim "g1" set
@ -102,7 +102,7 @@ dup layout
swap dup quot>> call swap dup quot>> call
dup layout dup layout
model>> dependencies>> [ range-max value>> ] map model>> dependencies>> [ range-max value>> ] map
viewport-gap 2 v*n = viewport-padding =
] unit-test ] unit-test
\ <scroller> must-infer \ <scroller> must-infer

View File

@ -3,7 +3,7 @@ strings math regexp regexp.backend ;
IN: validators IN: validators
HELP: v-checkbox HELP: v-checkbox
{ $values { "str" string } } { $values { "str" string } { "?" "a boolean" } }
{ $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ; { $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ;
HELP: v-captcha HELP: v-captcha

View File

@ -2,11 +2,11 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp unicode.categories arrays math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog ; hashtables words classes quotations xmode.catalog unicode.case ;
IN: validators IN: validators
: v-checkbox ( str -- ? ) : v-checkbox ( str -- ? )
"on" = ; >lower "on" = ;
: v-default ( str def -- str/def ) : v-default ( str def -- str/def )
over empty? spin ? ; over empty? spin ? ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel windows.types ; USING: alien alien.syntax kernel windows.types multiline ;
IN: windows.kernel32 IN: windows.kernel32
CONSTANT: MAX_PATH 260 CONSTANT: MAX_PATH 260
@ -197,6 +197,19 @@ CONSTANT: THREAD_PRIORITY_LOWEST -2
CONSTANT: THREAD_PRIORITY_NORMAL 0 CONSTANT: THREAD_PRIORITY_NORMAL 0
CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15 CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15
C-ENUM:
ComputerNameNetBIOS
ComputerNameDnsHostname
ComputerNameDnsDomain
ComputerNameDnsFullyQualified
ComputerNamePhysicalNetBIOS
ComputerNamePhysicalDnsHostname
ComputerNamePhysicalDnsDomain
ComputerNamePhysicalDnsFullyQualified
ComputerNameMax ;
TYPEDEF: uint COMPUTER_NAME_FORMAT
C-STRUCT: OVERLAPPED C-STRUCT: OVERLAPPED
{ "UINT_PTR" "internal" } { "UINT_PTR" "internal" }
{ "UINT_PTR" "internal-high" } { "UINT_PTR" "internal-high" }
@ -319,6 +332,249 @@ C-STRUCT: GUID
{ "WORD" "Data3" } { "WORD" "Data3" }
{ { "UCHAR" 8 } "Data4" } ; { { "UCHAR" 8 } "Data4" } ;
/*
fBinary :1;
fParity :1;
fOutxCtsFlow :1;
fOutxDsrFlow :1;
fDtrControl :2;
fDsrSensitivity :1;
fTXContinueOnXoff :1;
fOutX :1;
fInX :1;
fErrorChar :1;
fNull :1;
fRtsControl :2;
fAbortOnError :1;
fDummy2 :17;
*/
CONSTANT: SP_SERIALCOMM HEX: 1
CONSTANT: BAUD_075 HEX: 1
CONSTANT: BAUD_110 HEX: 2
CONSTANT: BAUD_134_5 HEX: 4
CONSTANT: BAUD_150 HEX: 8
CONSTANT: BAUD_300 HEX: 10
CONSTANT: BAUD_600 HEX: 20
CONSTANT: BAUD_1200 HEX: 40
CONSTANT: BAUD_1800 HEX: 80
CONSTANT: BAUD_2400 HEX: 100
CONSTANT: BAUD_4800 HEX: 200
CONSTANT: BAUD_7200 HEX: 400
CONSTANT: BAUD_9600 HEX: 800
CONSTANT: BAUD_14400 HEX: 1000
CONSTANT: BAUD_19200 HEX: 2000
CONSTANT: BAUD_38400 HEX: 4000
CONSTANT: BAUD_56K HEX: 8000
CONSTANT: BAUD_57600 HEX: 40000
CONSTANT: BAUD_115200 HEX: 20000
CONSTANT: BAUD_128K HEX: 10000
CONSTANT: BAUD_USER HEX: 10000000
CONSTANT: PST_FAX HEX: 21
CONSTANT: PST_LAT HEX: 101
CONSTANT: PST_MODEM HEX: 6
CONSTANT: PST_NETWORK_BRIDGE HEX: 100
CONSTANT: PST_PARALLELPORT HEX: 2
CONSTANT: PST_RS232 HEX: 1
CONSTANT: PST_RS422 HEX: 3
CONSTANT: PST_RS423 HEX: 4
CONSTANT: PST_RS449 HEX: 5
CONSTANT: PST_SCANNER HEX: 22
CONSTANT: PST_TCPIP_TELNET HEX: 102
CONSTANT: PST_UNSPECIFIED 0
CONSTANT: PST_X25 HEX: 103
CONSTANT: PCF_16BITMODE HEX: 200
CONSTANT: PCF_DTRDSR HEX: 1
CONSTANT: PCF_INTTIMEOUTS HEX: 80
CONSTANT: PCF_PARITY_CHECK HEX: 8
CONSTANT: PCF_RLSD HEX: 4
CONSTANT: PCF_RTSCTS HEX: 2
CONSTANT: PCF_SETXCHAR HEX: 20
CONSTANT: PCF_SPECIALCHARS HEX: 100
CONSTANT: PCF_TOTALTIMEOUTS HEX: 40
CONSTANT: PCF_XONXOFF HEX: 10
CONSTANT: SP_BAUD HEX: 2
CONSTANT: SP_DATABITS HEX: 4
CONSTANT: SP_HANDSHAKING HEX: 10
CONSTANT: SP_PARITY HEX: 1
CONSTANT: SP_PARITY_CHECK HEX: 20
CONSTANT: SP_RLSD HEX: 40
CONSTANT: SP_STOPBITS HEX: 8
CONSTANT: DATABITS_5 1
CONSTANT: DATABITS_6 2
CONSTANT: DATABITS_7 4
CONSTANT: DATABITS_8 8
CONSTANT: DATABITS_16 16
CONSTANT: DATABITS_16X 32
CONSTANT: STOPBITS_10 1
CONSTANT: STOPBITS_15 2
CONSTANT: STOPBITS_20 4
CONSTANT: PARITY_NONE 256
CONSTANT: PARITY_ODD 512
CONSTANT: PARITY_EVEN 1024
CONSTANT: PARITY_MARK 2048
CONSTANT: PARITY_SPACE 4096
CONSTANT: COMMPROP_INITIALIZED HEX: e73cf52e
CONSTANT: CBR_110 110
CONSTANT: CBR_300 300
CONSTANT: CBR_600 600
CONSTANT: CBR_1200 1200
CONSTANT: CBR_2400 2400
CONSTANT: CBR_4800 4800
CONSTANT: CBR_9600 9600
CONSTANT: CBR_14400 14400
CONSTANT: CBR_19200 19200
CONSTANT: CBR_38400 38400
CONSTANT: CBR_56000 56000
CONSTANT: CBR_57600 57600
CONSTANT: CBR_115200 115200
CONSTANT: CBR_128000 128000
CONSTANT: CBR_256000 256000
CONSTANT: DTR_CONTROL_DISABLE 0
CONSTANT: DTR_CONTROL_ENABLE 1
CONSTANT: DTR_CONTROL_HANDSHAKE 2
CONSTANT: RTS_CONTROL_DISABLE 0
CONSTANT: RTS_CONTROL_ENABLE 1
CONSTANT: RTS_CONTROL_HANDSHAKE 2
CONSTANT: RTS_CONTROL_TOGGLE 3
CONSTANT: EVENPARITY 2
CONSTANT: MARKPARITY 3
CONSTANT: NOPARITY 0
CONSTANT: ODDPARITY 1
CONSTANT: SPACEPARITY 4
CONSTANT: ONESTOPBIT 0
CONSTANT: ONE5STOPBITS 1
CONSTANT: TWOSTOPBITS 2
! Flowcontrol bit mask in DCB
CONSTANT: FM_fBinary HEX: 1
CONSTANT: FM_fParity HEX: 2
CONSTANT: FM_fOutxCtsFlow HEX: 4
CONSTANT: FM_fOutxDsrFlow HEX: 8
CONSTANT: FM_fDtrControl HEX: 30
CONSTANT: FM_fDsrSensitivity HEX: 40
CONSTANT: FM_fTXContinueOnXoff HEX: 80
CONSTANT: FM_fOutX HEX: 100
CONSTANT: FM_fInX HEX: 200
CONSTANT: FM_fErrorChar HEX: 400
CONSTANT: FM_fNull HEX: 800
CONSTANT: FM_fRtsControl HEX: 3000
CONSTANT: FM_fAbortOnError HEX: 4000
CONSTANT: FM_fDummy2 HEX: ffff8000
CONSTANT: BM_fCtsHold HEX: 1
CONSTANT: BM_fDsrHold HEX: 2
CONSTANT: BM_fRlsdHold HEX: 4
CONSTANT: BM_fXoffHold HEX: 8
CONSTANT: BM_fXoffSent HEX: 10
CONSTANT: BM_fEof HEX: 20
CONSTANT: BM_fTxim HEX: 40
CONSTANT: BM_AllBits HEX: 7f
! PurgeComm bit mask
CONSTANT: PURGE_TXABORT HEX: 1
CONSTANT: PURGE_RXABORT HEX: 2
CONSTANT: PURGE_TXCLEAR HEX: 4
CONSTANT: PURGE_RXCLEAR HEX: 8
! GetCommModemStatus bit mask
CONSTANT: MS_CTS_ON HEX: 10
CONSTANT: MS_DSR_ON HEX: 20
CONSTANT: MS_RING_ON HEX: 40
CONSTANT: MS_RLSD_ON HEX: 80
! EscapeCommFunction operations
CONSTANT: SETXOFF HEX: 1
CONSTANT: SETXON HEX: 2
CONSTANT: SETRTS HEX: 3
CONSTANT: CLRRTS HEX: 4
CONSTANT: SETDTR HEX: 5
CONSTANT: CLRDTR HEX: 6
CONSTANT: SETBREAK HEX: 8
CONSTANT: CLRBREAK HEX: 9
! ClearCommError bit mask
CONSTANT: CE_RXOVER HEX: 1
CONSTANT: CE_OVERRUN HEX: 2
CONSTANT: CE_RXPARITY HEX: 4
CONSTANT: CE_FRAME HEX: 8
CONSTANT: CE_BREAK HEX: 10
CONSTANT: CE_TXFULL HEX: 100
! LPT only
CONSTANT: CE_PTO HEX: 200
CONSTANT: CE_IOE HEX: 400
CONSTANT: CE_DNS HEX: 800
CONSTANT: CE_OOP HEX: 1000
! LPT only
CONSTANT: CE_MODE HEX: 8000
! GetCommMask bits
CONSTANT: EV_RXCHAR HEX: 1
CONSTANT: EV_RXFLAG HEX: 2
CONSTANT: EV_TXEMPTY HEX: 4
CONSTANT: EV_CTS HEX: 8
CONSTANT: EV_DSR HEX: 10
CONSTANT: EV_RLSD HEX: 20
CONSTANT: EV_BREAK HEX: 40
CONSTANT: EV_ERR HEX: 80
CONSTANT: EV_RING HEX: 100
CONSTANT: EV_PERR HEX: 200
CONSTANT: EV_RX80FULL HEX: 400
CONSTANT: EV_EVENT1 HEX: 800
CONSTANT: EV_EVENT2 HEX: 1000
C-STRUCT: DCB
{ "DWORD" "DCBlength" }
{ "DWORD" "BaudRate" }
{ "DWORD" "flags" }
{ "WORD" "wReserved" }
{ "WORD" "XonLim" }
{ "WORD" "XoffLim" }
{ "BYTE" "ByteSize" }
{ "BYTE" "Parity" }
{ "BYTE" "StopBits" }
{ "char" "XonChar" }
{ "char" "XoffChar" }
{ "char" "ErrorChar" }
{ "char" "EofChar" }
{ "char" "EvtChar" }
{ "WORD" "wReserved1" } ;
TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB
C-STRUCT: COMM_CONFIG
{ "DWORD" "dwSize" }
{ "WORD" "wVersion" }
{ "WORD" "wReserved" }
{ "DCB" "dcb" }
{ "DWORD" "dwProviderSubType" }
{ "DWORD" "dwProviderOffset" }
{ "DWORD" "dwProviderSize" }
{ { "WCHAR" 1 } "wcProviderData" } ;
TYPEDEF: COMMCONFIG* LPCOMMCONFIG
C-STRUCT: COMMPROP
{ "WORD" "wPacketLength" }
{ "WORD" "wPacketVersion" }
{ "DWORD" "dwServiceMask" }
{ "DWORD" "dwReserved1" }
{ "DWORD" "dwMaxTxQueue" }
{ "DWORD" "dwMaxRxQueue" }
{ "DWORD" "dwMaxBaud" }
{ "DWORD" "dwProvSubType" }
{ "DWORD" "dwProvCapabilities" }
{ "DWORD" "dwSettableParams" }
{ "DWORD" "dwSettableBaud" }
{ "WORD" "wSettableData" }
{ "WORD" "wSettableStopParity" }
{ "DWORD" "dwCurrentTxQueue" }
{ "DWORD" "dwCurrentRxQueue" }
{ "DWORD" "dwProvSpec1" }
{ "DWORD" "dwProvSpec2" }
{ { "WCHAR" 1 } "wcProvChar" } ;
TYPEDEF: COMMPROP* LPCOMMPROP
CONSTANT: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege" CONSTANT: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege"
CONSTANT: SE_ASSIGNPRIMARYTOKEN_NAME "SeAssignPrimaryTokenPrivilege" CONSTANT: SE_ASSIGNPRIMARYTOKEN_NAME "SeAssignPrimaryTokenPrivilege"
@ -875,19 +1131,19 @@ ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
! FUNCTION: GetCalendarInfoW ! FUNCTION: GetCalendarInfoW
! FUNCTION: GetCommandLineA ! FUNCTION: GetCommandLineA
! FUNCTION: GetCommandLineW ! FUNCTION: GetCommandLineW
! FUNCTION: GetCommConfig FUNCTION: BOOL GetCommConfig ( HANDLE hCommDev, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
! FUNCTION: GetCommMask FUNCTION: BOOL GetCommMask ( HANDLE hFile, LPDWORD lpEvtMask ) ;
! FUNCTION: GetCommModemStatus FUNCTION: BOOL GetCommModemStatus ( HANDLE hFile, LPDWORD lpModemStat ) ;
! FUNCTION: GetCommProperties FUNCTION: BOOL GetCommProperties ( HANDLE hFile, LPCOMMPROP lpCommProp ) ;
! FUNCTION: GetCommState FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: GetCommTimeouts ! FUNCTION: GetCommTimeouts
! FUNCTION: GetComPlusPackageInstallStatus ! FUNCTION: GetComPlusPackageInstallStatus
! FUNCTION: GetCompressedFileSizeA ! FUNCTION: GetCompressedFileSizeA
! FUNCTION: GetCompressedFileSizeW ! FUNCTION: GetCompressedFileSizeW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
! FUNCTION: GetComputerNameExW
! FUNCTION: GetComputerNameW
ALIAS: GetComputerName GetComputerNameW ALIAS: GetComputerName GetComputerNameW
FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ;
ALIAS: GetComputerNameEx GetComputerNameExW
! FUNCTION: GetConsoleAliasA ! FUNCTION: GetConsoleAliasA
! FUNCTION: GetConsoleAliasesA ! FUNCTION: GetConsoleAliasesA
! FUNCTION: GetConsoleAliasesLengthA ! FUNCTION: GetConsoleAliasesLengthA
@ -942,7 +1198,8 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetDateFormatA ! FUNCTION: GetDateFormatA
! FUNCTION: GetDateFormatW ! FUNCTION: GetDateFormatW
! FUNCTION: GetDefaultCommConfigA ! FUNCTION: GetDefaultCommConfigA
! FUNCTION: GetDefaultCommConfigW FUNCTION: BOOL GetDefaultCommConfigW ( LPCTSTR lpszName, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
ALIAS: GetDefaultCommConfig GetDefaultCommConfigW
! FUNCTION: GetDefaultSortkeySize ! FUNCTION: GetDefaultSortkeySize
! FUNCTION: GetDevicePowerState ! FUNCTION: GetDevicePowerState
! FUNCTION: GetDiskFreeSpaceA ! FUNCTION: GetDiskFreeSpaceA
@ -1400,10 +1657,10 @@ ALIAS: RemoveDirectory RemoveDirectoryW
! FUNCTION: SetCalendarInfoA ! FUNCTION: SetCalendarInfoA
! FUNCTION: SetCalendarInfoW ! FUNCTION: SetCalendarInfoW
! FUNCTION: SetClientTimeZoneInformation ! FUNCTION: SetClientTimeZoneInformation
! FUNCTION: SetCommBreak FUNCTION: BOOL SetCommBreak ( HANDLE hFile ) ;
! FUNCTION: SetCommConfig FUNCTION: BOOL SetCommConfig ( HANDLE hCommDev, LPCOMMCONFIG lpCC, DWORD dwSize ) ;
! FUNCTION: SetCommMask FUNCTION: BOOL SetCommMask ( HANDLE hFile, DWORD dwEvtMask ) ;
! FUNCTION: SetCommState FUNCTION: BOOL SetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: SetCommTimeouts ! FUNCTION: SetCommTimeouts
! FUNCTION: SetComPlusPackageInstallStatus ! FUNCTION: SetComPlusPackageInstallStatus
! FUNCTION: SetComputerNameA ! FUNCTION: SetComputerNameA
@ -1446,7 +1703,8 @@ ALIAS: SetConsoleTitle SetConsoleTitleW
FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ;
ALIAS: SetCurrentDirectory SetCurrentDirectoryW ALIAS: SetCurrentDirectory SetCurrentDirectoryW
! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigA
! FUNCTION: SetDefaultCommConfigW FUNCTION: BOOL SetDefaultCommConfigW ( LPCTSTR lpszName, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
ALIAS: SetDefaultCommConfig SetDefaultCommConfigW
! FUNCTION: SetDllDirectoryA ! FUNCTION: SetDllDirectoryA
! FUNCTION: SetDllDirectoryW ! FUNCTION: SetDllDirectoryW
FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ; FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ;

View File

@ -1,13 +1,13 @@
USING: accessors combinators.cleave combinators.short-circuit USING: accessors combinators.cleave combinators.short-circuit
concurrency.combinators destructors fry io io.directories concurrency.combinators destructors fry io io.directories
io.encodings io.encodings.utf8 io.launcher io.pathnames io.encodings io.encodings.utf8 io.launcher io.monitors
io.pipes io.ports kernel locals math namespaces sequences io.pathnames io.pipes io.ports kernel locals math namespaces
splitting strings ui ui.gadgets ui.gadgets.buttons sequences splitting strings threads ui ui.gadgets
ui.gadgets.editors ui.gadgets.labels ui.gadgets.packs ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
ui.gadgets.tracks ; ui.gadgets.packs ui.gadgets.tracks ;
IN: git-status IN: git-tool
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -116,11 +116,11 @@ TUPLE: <git-status>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: refresh-git-status ( GIT-STATUS -- GIT-STATUS ) :: refresh-git-status ( STATUS -- STATUS )
[let | LINES [ GIT-STATUS repository>> "git-status" git-process stdout>> ] | [let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
GIT-STATUS STATUS
LINES "# Changes to be committed:" git-status-section LINES "# Changes to be committed:" git-status-section
[ "new file:" head? ] filter [ "new file:" head? ] filter
@ -269,7 +269,7 @@ TUPLE: <git-status>
"Diff" "Diff"
[ [
drop drop
STATUS repository>> { "git-diff" PATH } git-process STATUS repository>> { "git" "diff" PATH } git-process
popup-process-window popup-process-window
] ]
<bevel-button> add-gadget <bevel-button> add-gadget
@ -320,7 +320,7 @@ TUPLE: <git-status>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: git-remote-branches ( REPO NAME -- seq ) :: git-remote-branches ( REPO NAME -- seq )
REPO { "git-remote" "show" NAME } git-process stdout>> REPO { "git" "remote" "show" NAME } git-process stdout>>
" Tracked remote branches" over index 1 + tail first " " split " Tracked remote branches" over index 1 + tail first " " split
[ empty? not ] filter ; [ empty? not ] filter ;
@ -334,7 +334,7 @@ TUPLE: <git-status>
"Remotes" <label> reverse-video-theme add-gadget "Remotes" <label> reverse-video-theme add-gadget
REPO "git-remote" git-process stdout>> [ empty? not ] filter REPO { "git" "remote" } git-process stdout>> [ empty? not ] filter
[| NAME | [| NAME |
@ -377,7 +377,7 @@ TUPLE: <git-status>
1 track-add ] 1 track-add ]
"Fetch" "Fetch"
[ drop REPO { "git-fetch" NAME } git-process popup-process-window ] [ drop REPO { "git" "fetch" NAME } git-process popup-process-window ]
<bevel-button> <bevel-button>
1 track-add 1 track-add
@ -385,7 +385,7 @@ TUPLE: <git-status>
[ [
drop drop
[let | ARG [ { ".." NAME "/" BRANCH } concat ] | [let | ARG [ { ".." NAME "/" BRANCH } concat ] |
REPO { "git-log" ARG } git-process popup-process-window ] REPO { "git" "log" ARG } git-process popup-process-window ]
] ]
<bevel-button> <bevel-button>
1 track-add 1 track-add
@ -394,7 +394,7 @@ TUPLE: <git-status>
[ [
drop drop
[let | ARG [ { NAME "/" BRANCH } concat ] | [let | ARG [ { NAME "/" BRANCH } concat ] |
REPO { "git-merge" ARG } git-process popup-process-window ] REPO { "git" "merge" ARG } git-process popup-process-window ]
] ]
<bevel-button> <bevel-button>
1 track-add 1 track-add
@ -403,7 +403,7 @@ TUPLE: <git-status>
[ [
drop drop
[let | ARG [ { NAME "/" BRANCH ".." } concat ] | [let | ARG [ { NAME "/" BRANCH ".." } concat ] |
REPO { "git-log" ARG } git-process popup-process-window ] REPO { "git" "log" ARG } git-process popup-process-window ]
] ]
<bevel-button> <bevel-button>
1 track-add 1 track-add
@ -411,7 +411,7 @@ TUPLE: <git-status>
"Push" "Push"
[ [
drop drop
REPO { "git-push" NAME "master" } git-process popup-process-window REPO { "git" "push" NAME "master" } git-process popup-process-window
] ]
<bevel-button> <bevel-button>
1 track-add 1 track-add
@ -433,8 +433,32 @@ TUPLE: <git-status>
<label> <label>
add-gadget add-gadget
REPO git-status <pile> 1 >>fill tuck refresh-status-pile add-gadget [let | STATUS [ REPO git-status ]
REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget PILE [ <pile> 1 >>fill ] |
[
[
[let | MONITOR [ REPO t <monitor> ] |
[
[let | PATH [ MONITOR next-change drop ] |
".git" PATH subseq? ! Ignore git internal operations
[ ]
[ STATUS PILE refresh-status-pile ]
if
t ]
]
loop
]
]
with-monitors
]
in-thread
STATUS PILE refresh-status-pile
PILE add-gadget ]
REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
"Git" open-window ; "Git" open-window ;

View File

@ -20,4 +20,5 @@ M: serial dispose ( serial -- ) stream>> dispose ;
{ {
{ [ os unix? ] [ "serial.unix" ] } { [ os unix? ] [ "serial.unix" ] }
{ [ os windows? ] [ "serial.windows" ] }
} cond require } cond require

View File

View File

@ -0,0 +1 @@
unportable

View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test serial.windows ;
IN: serial.windows.tests

View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files.windows io.streams.duplex kernel math
math.bitwise windows.kernel32 accessors alien.c-types
windows io.files.windows fry locals continuations ;
IN: serial.windows
: <serial-stream> ( path encoding -- duplex )
[ open-r/w dup ] dip <encoder-duplex> ;
: get-comm-state ( duplex -- dcb )
in>> handle>>
"DCB" <c-object> tuck
GetCommState win32-error=0/f ;
: set-comm-state ( duplex dcb -- )
[ in>> handle>> ] dip
SetCommState win32-error=0/f ;
:: with-comm-state ( duplex quot: ( dcb -- ) -- )
duplex get-comm-state :> dcb
dcb clone quot curry [ dcb set-comm-state ] recover ; inline

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,35 +0,0 @@
USING: kernel sequences quotations assocs math math.parser
combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.interpret
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: command-table
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: exec-command ( string -- ) command-table> at >quotation call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: command ( string -- command ) 1 head ;
: parameter ( string -- parameter )
[ drop 2 ] [ length 1- ] [ ] tri subseq string>number ;
: exec-command* ( string -- )
[ parameter ] [ command ] bi
command-table> at dup
[ 1 tail* call ] [ 2drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (interpret) ( slice -- )
{ { [ empty? ] [ drop ] }
{ [ has-param? ] [ next+rest* [ exec-command* ] [ (interpret) ] bi* ] }
{ [ t ] [ next+rest [ exec-command ] [ (interpret) ] bi* ] } }
switch ;
: interpret ( string -- ) <flat-slice> (interpret) ;

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,36 +0,0 @@
USING: kernel sbufs strings sequences assocs math
combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: rules
: lookup ( str -- str ) [ 1 head rules> at ] [ ] bi or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: accum
: push-next ( next -- ) lookup accum> push-all ;
: (rewrite) ( slice -- )
{ { [ empty? ] [ drop ] }
{ [ has-param? ] [ next+rest* [ push-next ] [ (rewrite) ] bi* ] }
{ [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } }
switch ;
: rewrite ( string -- string )
dup length 10 * <sbuf> >accum
<flat-slice> (rewrite)
accum> >string ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: result
: iterate ( -- ) result> rewrite >result ;
: iterations ( n -- ) [ iterate ] times ;

View File

@ -1,14 +0,0 @@
USING: kernel sequences math combinators.lib combinators.short-circuit ;
IN: lsys.strings
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: has-param? ( slice -- ? ) { [ length 1 > ] [ second CHAR: ( = ] } 1&& ;
: next+rest ( slice -- next rest ) [ 1 head ] [ 1 tail-slice ] bi ;
: index-rest ( slice -- i ) CHAR: ) swap index 1+ ;
: next+rest* ( slice -- next rest ) dup index-rest [ head ] [ tail-slice ] 2bi ;

View File

@ -1 +0,0 @@
Lindenmayer system explorer

View File

@ -1 +0,0 @@
applications

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,153 +0,0 @@
USING: kernel math vectors sequences opengl.gl math.vectors math.order
math.matrices vars opengl self pos ori turtle lsys.tortoise
lsys.strings.interpret combinators.short-circuit ;
! lsys.strings
IN: lsys.tortoise.graphics
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! (v0 - v1) x (v1 - v2)
: polygon-normal ( {_v0_v1_v2_} -- normal ) first3 dupd v- -rot v- swap cross ;
: (polygon) ( vertices -- )
GL_POLYGON glBegin
dup polygon-normal gl-normal [ gl-vertex ] each
glEnd ;
: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: vertices
! : init-vertices ( -- ) 0 <vector> >vertices ;
: start-polygon ( -- ) vertices> delete-all ;
: finish-polygon ( -- ) vertices> polygon ;
: polygon-vertex ( -- ) pos> vertices> push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-vertex ( -- ) pos> gl-vertex ;
: draw-forward ( length -- )
GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
: move-forward ( length -- ) step-turtle polygon-vertex ;
: sneak-forward ( length -- ) step-turtle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: scale-len ( m -- ) len> * >len ;
: scale-angle ( m -- ) angle> * >angle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-thickness ( i -- ) dup >thickness glLineWidth ;
: scale-thickness ( m -- ) thickness> * 0.5 max set-thickness ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: color-table
: init-color-table ( -- )
{ { 0 0 0 } ! black
{ 0.5 0.5 0.5 } ! grey
{ 1 0 0 } ! red
{ 1 1 0 } ! yellow
{ 0 1 0 } ! green
{ 0.25 0.88 0.82 } ! turquoise
{ 0 0 1 } ! blue
{ 0.63 0.13 0.94 } ! purple
{ 0.00 0.50 0.00 } ! dark green
{ 0.00 0.82 0.82 } ! dark turquoise
{ 0.00 0.00 0.50 } ! dark blue
{ 0.58 0.00 0.82 } ! dark purple
{ 0.50 0.00 0.00 } ! dark red
{ 0.25 0.25 0.25 } ! dark grey
{ 0.75 0.75 0.75 } ! medium grey
{ 1 1 1 } ! white
} [ 1 suffix ] map >color-table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: material-color ( color -- )
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
: set-color ( i -- )
dup >color color-table> nth dup gl-color material-color ;
: inc-color ( -- ) color> 1+ set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: tortoise-stack
! : init-tortoise-stack ( -- ) V{ } clone >tortoise-stack ;
! : save-tortoise ( -- ) self> tortoise-stack> push ;
! : save-tortoise ( -- ) self> tortoise-stack> push self> clone >self ;
: save-tortoise ( -- ) self> clone tortoise-stack> push ;
: restore-tortoise ( -- )
tortoise-stack> pop >self
color> set-color
thickness> set-thickness ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: default-values
VAR: model-values
: lparser-dialect ( -- )
[ 1 >len 45 >angle 1 >thickness 2 >color ] >default-values
H{ { "+" [ angle> turn-left ] }
{ "-" [ angle> turn-right ] }
{ "&" [ angle> pitch-down ] }
{ "^" [ angle> pitch-up ] }
{ "<" [ angle> roll-left ] }
{ ">" [ angle> roll-right ] }
{ "|" [ 180.0 rotate-y ] }
{ "%" [ 180.0 rotate-z ] }
{ "$" [ roll-until-horizontal ] }
{ "F" [ len> draw-forward ] }
{ "Z" [ len> 2 / draw-forward ] }
{ "f" [ len> move-forward ] }
{ "z" [ len> 2 / move-forward ] }
{ "g" [ len> sneak-forward ] }
{ "." [ polygon-vertex ] }
{ "[" [ save-tortoise ] }
{ "]" [ restore-tortoise ] }
{ "{" [ start-polygon ] }
{ "}" [ finish-polygon ] }
{ "/" [ 1.1 scale-len ] } ! double quote command in lparser
{ "'" [ 0.9 scale-len ] }
{ ";" [ 1.1 scale-angle ] }
{ ":" [ 0.9 scale-angle ] }
{ "?" [ 1.4 scale-thickness ] }
{ "!" [ 0.7 scale-thickness ] }
{ "c" [ color> 1 + color-table> length mod set-color ] }
} >command-table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,31 +0,0 @@
USING: kernel generic math arrays
math.matrices generic.lib pos ori self turtle ;
IN: lsys.tortoise
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: tortoise angle len thickness color ;
: <tortoise> ( -- tortoise )
<turtle> tortoise construct-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: angle> ( -- val ) self> tortoise-angle ;
: >angle ( val -- ) self> set-tortoise-angle ;
: len> ( -- val ) self> tortoise-len ;
: >len ( val -- ) self> set-tortoise-len ;
: thickness> ( -- val ) self> tortoise-thickness ;
: >thickness ( val -- ) self> set-tortoise-thickness ;
: color> ( -- val ) self> tortoise-color ;
: >color ( val -- ) self> set-tortoise-color ;

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,13 +0,0 @@
USING: tools.deploy.config ;
V{
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 2 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? t }
{ deploy-word-defs? t }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-name "Lindenmayer System Explorer" }
}

View File

@ -1 +0,0 @@
demos

View File

@ -1,507 +0,0 @@
USING: kernel namespaces threads math math.order math.vectors
quotations sequences
opengl
opengl.gl
colors
ui
ui.gestures
ui.gadgets
ui.gadgets.packs
ui.gadgets.labels
ui.gadgets.buttons
ui.gadgets.lib
ui.gadgets.slate
ui.gadgets.theme
vars rewrite-closures
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret
combinators.short-circuit accessors ;
! lsys.strings
! lsys.strings.rewrite
! lsys.strings.interpret
IN: lsys.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: slate
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: camera
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: model
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: display ( -- )
black set-clear-color GL_COLOR_BUFFER_BIT glClear
GL_FLAT glShadeModel
GL_PROJECTION glMatrixMode
glLoadIdentity
-1 1 -1 1 1.5 200 glFrustum
GL_MODELVIEW glMatrixMode
glLoadIdentity
camera> do-look-at
GL_FRONT_AND_BACK GL_LINE glPolygonMode
white color>raw glColor4d
! white set-color
GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
color> set-color
model> glCallList ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: result>model ( -- )
slate> find-gl-context
model> GL_COMPILE glNewList result> interpret glEndList ;
: build-model ( -- )
tortoise-stack> delete-all
vertices> delete-all
reset-turtle
default-values> call
model-values> call
result>model
[ display ] closed-quot slate> set-slate-action
slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: hashtables namespaces.lib ui.gadgets.handler ;
: camera-action ( quot -- quot )
[ drop [ ] camera> with-self slate> relayout-1 ] make* closed-quot ;
VAR: frame
VAR: handler
DEFER: model-chooser
DEFER: scene-chooser
DEFER: empty-model
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: lsys-controller ( -- )
<pile>
{
[ "Load" <label> reverse-video-theme ]
[ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
[ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
[ "Model" <label> reverse-video-theme ]
[ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
[ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
[ "Camera" <label> reverse-video-theme ]
[ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
[ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]
[ "Pitch down" <label> [ 5 pitch-down ] camera-action <bevel-button> ]
[ "Pitch up" <label> [ 5 pitch-up ] camera-action <bevel-button> ]
[ "Forward - a" <label> [ 1 step-turtle ] camera-action <bevel-button> ]
[ "Backward - z" <label> [ -1 step-turtle ] camera-action <bevel-button> ]
[ "Roll left - q" <label> [ 5 roll-left ] camera-action <bevel-button> ]
[ "Roll right - w" <label> [ 5 roll-right ] camera-action <bevel-button> ]
[ "Strafe left - (alt)" <label> [ 1 strafe-left ] camera-action <bevel-button> ]
[ "Strafe right - (alt)" <label> [ 1 strafe-right ] camera-action <bevel-button> ]
[ "Strafe down - (alt)" <label> [ 1 strafe-up ] camera-action <bevel-button> ]
[ "Strafe up - (alt)" <label> [ 1 strafe-down ] camera-action <bevel-button> ]
[ "View 1 - 1" <label>
[ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
camera-action <bevel-button> ]
[ "View 2 - 2" <label>
[ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
camera-action <bevel-button> ]
[ "View 3 - 3" <label>
[ pos> norm reset-turtle step-turtle 180 turn-left ]
camera-action <bevel-button> ]
[ "View 4 - 4" <label>
[ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action <bevel-button> ]
}
[ call add-gadget ] each
1 >>fill
"L-system control" open-window ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: lsys-viewer ( -- )
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-pdim
slate> <handler>
{
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] camera-action ] }
{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] camera-action ] }
{ T{ key-down f f "UP" } [ [ 5 pitch-down ] camera-action ] }
{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] camera-action ] }
{ T{ key-down f f "a" } [ [ 1 step-turtle ] camera-action ] }
{ T{ key-down f f "z" } [ [ -1 step-turtle ] camera-action ] }
{ T{ key-down f f "q" } [ [ 5 roll-left ] camera-action ] }
{ T{ key-down f f "w" } [ [ 5 roll-right ] camera-action ] }
{ T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] camera-action ] }
{ T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] camera-action ] }
{ T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] camera-action ] }
{ T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] camera-action ] }
{ T{ key-down f f "1" }
[ [ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
camera-action ] }
{ T{ key-down f f "2" }
[ [ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
camera-action ] }
{ T{ key-down f f "3" }
[ [ pos> norm reset-turtle step-turtle 180 turn-left ]
camera-action ] }
{ T{ key-down f f "4" }
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action ] }
} [ make* ] map >hashtable >>table
"L-system view" open-window
500 sleep
slate> find-gl-context
1 glGenLists >model
<turtle> >camera
[ camera> >self
reset-turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left
] with-scope
init-color-table
<tortoise> >self
V{ } clone >tortoise-stack
V{ } clone >vertices
empty-model
build-model
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Examples
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: koch ( -- ) lparser-dialect [ 90 >angle ] >model-values
H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
{ "k" "[ c'(0.5) K]" }
{ "a" "[d <(120) d <(120) d ]" }
{ "b" "e" }
{ "e" "[^ '(.2887)f'(3.4758) &(180) +z{.-(120)f-(120)f}]" }
{ "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
} >rules
"K" >result ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: spiral-0 ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
"[P]|[P]" >result
H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
{ "A" "F+;'A" }
{ "B" "F!+F+;'B" }
{ "C" "F!^+F^+;'C" }
{ "D" "F!>^+F>^+;'D" }
} >rules ;
: spiral-0-scene ( -- )
spiral-0
22 iterations
build-model
[ reset-turtle 90 turn-left 16 step-turtle 180 turn-left ]
camera> with-self slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: tree-5 ( -- ) lparser-dialect [ 5 >angle 1 >thickness ] >model-values
"c(4)FFS" >result
H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
{ "R" "[Ba]" }
{ "a" "$tF[Cx]Fb" }
{ "b" "$tF[Dy]Fa" }
{ "B" "&B" }
{ "C" "+C" }
{ "D" "-D" }
{ "x" "a" }
{ "y" "b" }
{ "F" "'(1.25)F'(.8)" }
} >rules ;
: tree-5-scene ( -- )
tree-5
9 iterations
build-model
[ reset-turtle 90 pitch-down -70 step-turtle 50 strafe-up ] camera> with-self
slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-1 ( -- ) lparser-dialect [ 45 >angle 5 >thickness ] >model-values
H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
} >rules
"c(12)FFAL" >result ;
: abop-1-scene ( -- )
abop-1
8 iterations
build-model
[ reset-turtle
90 pitch-up 7 step-turtle 90 pitch-down 4 step-turtle 90 pitch-down ]
camera> with-self slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-2 ( -- ) lparser-dialect [ 30 >angle 5 >thickness ] >model-values
H{ { "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){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
} >rules
"c(12)FAL" >result ;
: abop-2-scene ( -- )
abop-2
7 iterations
build-model
[ reset-turtle { 0 4 4 } >pos 90 pitch-down ]
camera> with-self slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-3 ( -- ) lparser-dialect [ 30 >angle 5 >thickness ] >model-values
H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
{ "B" "[&t(.4)F$A]" }
{ "F" "'(1.25)F'(.8)" }
} >rules
"c(12)FA" >result ;
: abop-3-scene ( -- )
abop-3 11 iterations build-model
[ reset-turtle { 0 47 29 } >pos 90 pitch-down ] camera> with-self
slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-4 ( -- ) lparser-dialect [ 18 >angle 5 >thickness ] >model-values
H{ { "N" "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK" }
{ "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
{ "l" "g(.2)l" }
{ "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
{ "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
{ "f" "_" }
{ "A" "B" }
{ "B" "C" }
{ "C" "D" }
{ "D" "E" }
{ "E" "G" }
{ "G" "H" }
{ "H" "N" }
{ "I" "FoO" }
{ "O" "FoP" }
{ "P" "FoQ" }
{ "Q" "FoR" }
{ "R" "FoS" }
{ "S" "FoT" }
{ "T" "FoU" }
{ "U" "FoV" }
{ "V" "FoW" }
{ "W" "FoX" }
{ "X" "_" }
{ "o" "$t(-0.03)" }
{ "r" "~(30)" }
} >rules
"c(12)&(20)N" >result ;
: abop-4-scene ( -- )
abop-4 21 iterations build-model
[ reset-turtle
{ 53 25 36 } >pos
{ { 0.57 -0.14 -0.80 } { -0.81 -0.18 -0.54 } { -0.07 0.97 -0.22 } }
>ori
] camera> with-self slate> relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-5 ( -- ) lparser-dialect [ 5 >angle 5 >thickness ] >model-values
H{ { "a" "F[+(45)l][-(45)l]^;ca" }
{ "l" "j" }
{ "j" "h" }
{ "h" "s" }
{ "s" "d" }
{ "d" "x" }
{ "x" "a" }
{ "F" "'(1.17)F'(.855)" }
} >rules
"&(90)+(90)a" >result ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-6 ( -- ) lparser-dialect [ 5 >angle 5 >thickness ] >model-values
"&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" >result
H{ { "a" "F[cdx][cex]F!(.9)a" }
{ "x" "a" }
{ "d" "+d" }
{ "e" "-e" }
{ "F" "'(1.25)F'(.8)" }
} >rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: airhorse ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
"C" >result
H{ { "C" "LBW" }
{ "B" "[[''aH]|[g]]" }
{ "a" "Fs+;'a" }
{ "g" "Ft+;'g" }
{ "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
{ "t" "[c!!!!&[FF]^^FF]" }
{ "L" "O" }
{ "O" "P" }
{ "P" "Q" }
{ "Q" "R" }
{ "R" "U" }
{ "U" "X" }
{ "X" "Y" }
{ "Y" "V" }
{ "V" "[cc!!!&(90)[Zp]|[Zp]]" }
{ "p" "h>(120)h>(120)h" }
{ "h" "[+(40)!F'''p]" }
{ "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
{ "d" "Z!&Z!&:'d" }
{ "e" "Z!^Z!^:'e" }
{ "i" "-:/i" }
{ "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
{ "b" "Fl!+Fl+;'b" }
{ "l" "[-cc{--z++z++z--|--z++z++z}]" }
} >rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: empty-model ( -- )
lparser-dialect
[ ] >model-values
" " >result
H{ } >rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: model-chooser ( -- )
<pile>
{
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
[ "abop-3" <label> [ drop abop-3 build-model ] closed-quot <bevel-button> ]
[ "abop-4" <label> [ drop abop-4 build-model ] closed-quot <bevel-button> ]
[ "abop-5" <label> [ drop abop-5 build-model ] closed-quot <bevel-button> ]
[ "abop-6" <label> [ drop abop-6 build-model ] closed-quot <bevel-button> ]
[ "tree-5" <label> [ drop tree-5 build-model ] closed-quot <bevel-button> ]
[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
}
[ call add-gadget ] each
1 >>fill
"L-system models" open-window ;
: scene-chooser ( -- )
<pile>
{
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
}
[ call add-gadget ] each
1 >>fill
"L-system scenes" open-window ;
: lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ;
MAIN: lsys-window*

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,47 +0,0 @@
USING: kernel math arrays math.vectors math.matrices generic.lib pos ori ;
IN: turtle
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: turtle ;
: <turtle> ( -- turtle )
turtle new
{ 0 0 0 } clone <pos>
3 identity-matrix <ori>
rot
3array chain ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reset-turtle ( -- ) { 0 0 0 } >pos 3 identity-matrix >ori ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: step-vector ( length -- array ) { 0 0 1 } n*v ;
: step-turtle ( length -- ) step-vector ori> swap m.v pos> v+ >pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: strafe-up ( length -- )
90 pitch-up
step-turtle
90 pitch-down ;
: strafe-down ( length -- )
90 pitch-down
step-turtle
90 pitch-up ;
: strafe-left ( length -- )
90 turn-left
step-turtle
90 turn-right ;
: strafe-right ( length -- )
90 turn-right
step-turtle
90 turn-left ;

View File

@ -1,4 +1,3 @@
WINDRES=windres WINDRES=windres
include vm/Config.windows.nt include vm/Config.windows.nt
include vm/Config.x86.32 include vm/Config.x86.32
#error "lolllll"

View File

@ -1,5 +1,3 @@
#WIN64_PATH=/k/MinGW/win64/bin
#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
CC=$(WIN64_PATH)-gcc.exe CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe WINDRES=$(WIN64_PATH)-windres.exe
include vm/Config.windows.nt include vm/Config.windows.nt