Merge branch 'master' into new-alien-pointers

db4
Joe Groff 2010-02-21 22:30:12 -08:00
commit 2a751106a8
22 changed files with 420 additions and 101 deletions

View File

@ -1,8 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors classes classes.algebra fry generic USING: arrays assocs accessors classes classes.algebra fry
kernel math namespaces sequences words sets generic kernel math namespaces sequences words sets
combinators.short-circuit classes.tuple ; combinators.short-circuit classes.tuple alien.c-types ;
FROM: classes.tuple.private => tuple-layout ; FROM: classes.tuple.private => tuple-layout ;
FROM: assocs => change-at ; FROM: assocs => change-at ;
IN: stack-checker.dependencies IN: stack-checker.dependencies
@ -38,6 +38,13 @@ SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
: depends-on-definition ( word -- ) : depends-on-definition ( word -- )
definition-dependency depends-on ; definition-dependency depends-on ;
GENERIC: depends-on-c-type ( c-type -- )
M: c-type-word depends-on-c-type depends-on-definition ;
M: array depends-on-c-type
[ word? ] filter [ depends-on-definition ] each ;
! Generic words that the current quotation depends on ! Generic words that the current quotation depends on
SYMBOL: generic-dependencies SYMBOL: generic-dependencies

View File

@ -5,7 +5,8 @@ io.encodings.ascii kernel namespaces
sequences locals system splitting tools.deploy.backend sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables tools.deploy.config tools.deploy.config.editor assocs hashtables
prettyprint combinators windows.kernel32 windows.shell32 windows.user32 prettyprint combinators windows.kernel32 windows.shell32 windows.user32
alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ; alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico
io.files.windows.nt ;
IN: tools.deploy.windows IN: tools.deploy.windows
CONSTANT: app-icon-resource-id "APPICON" CONSTANT: app-icon-resource-id "APPICON"
@ -22,6 +23,10 @@ CONSTANT: app-icon-resource-id "APPICON"
dup copy-dll dup copy-dll
deploy-ui? get ".exe" ".com" ? copy-vm ; deploy-ui? get ".exe" ".com" ? copy-vm ;
: open-in-explorer ( dir -- )
[ f "open" ] dip absolute-path normalize-separators
f f SW_SHOWNORMAL ShellExecute drop ;
: embed-ico ( vm vocab -- ) : embed-ico ( vm vocab -- )
dup vocab-windows-icon-path vocab-append-path dup exists? dup vocab-windows-icon-path vocab-append-path dup exists?
[ binary file-contents app-icon-resource-id embed-icon-resource ] [ binary file-contents app-icon-resource-id embed-icon-resource ]

View File

@ -101,6 +101,7 @@ FUNCTION: uid_t getuid ;
FUNCTION: uint htonl ( uint n ) ; FUNCTION: uint htonl ( uint n ) ;
FUNCTION: ushort htons ( ushort n ) ; FUNCTION: ushort htons ( ushort n ) ;
! FUNCTION: int issetugid ; ! FUNCTION: int issetugid ;
FUNCTION: int isatty ( int fildes ) ;
FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ;
FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ; FUNCTION: int listen ( int s, int backlog ) ;

View File

@ -405,7 +405,7 @@ CONSTANT: KEY_READ HEX: 20019
CONSTANT: KEY_WOW64_32KEY HEX: 0200 CONSTANT: KEY_WOW64_32KEY HEX: 0200
CONSTANT: KEY_WOW64_64KEY HEX: 0100 CONSTANT: KEY_WOW64_64KEY HEX: 0100
CONSTANT: KEY_WRITE HEX: 20006 CONSTANT: KEY_WRITE HEX: 20006
CONSTANT: KEY_EXECUTE KEY_READ ALIAS: KEY_EXECUTE KEY_READ
CONSTANT: KEY_ALL_ACCESS HEX: F003F CONSTANT: KEY_ALL_ACCESS HEX: F003F
CONSTANT: REG_NONE 0 CONSTANT: REG_NONE 0
@ -423,6 +423,9 @@ CONSTANT: REG_RESOURCE_REQUIREMENTS_LIST 10
CONSTANT: REG_QWORD 11 CONSTANT: REG_QWORD 11
CONSTANT: REG_QWORD_LITTLE_ENDIAN 11 CONSTANT: REG_QWORD_LITTLE_ENDIAN 11
CONSTANT: REG_CREATED_NEW_KEY 1
CONSTANT: REG_OPENED_EXISTING_KEY 2
TYPEDEF: DWORD REGSAM TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ; ! : I_ScGetCurrentGroupStateW ;
@ -926,6 +929,7 @@ FUNCTION: LONG RegCloseKey ( HKEY hKey ) ;
! : RegCreateKeyA ; ! : RegCreateKeyA ;
! : RegCreateKeyExA ; ! : RegCreateKeyExA ;
FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ; FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
ALIAS: RegCreateKeyEx RegCreateKeyExW
! : RegCreateKeyW ! : RegCreateKeyW
! : RegDeleteKeyA ; ! : RegDeleteKeyA ;
! : RegDeleteKeyW ; ! : RegDeleteKeyW ;
@ -949,6 +953,7 @@ ALIAS: RegDeleteKeyEx RegDeleteKeyExW
! : RegDisablePredefinedCache ; ! : RegDisablePredefinedCache ;
! : RegEnumKeyA ; ! : RegEnumKeyA ;
! : RegEnumKeyExA ; ! : RegEnumKeyExA ;
FUNCTION: LONG RegEnumKeyExW ( FUNCTION: LONG RegEnumKeyExW (
HKEY hKey, HKEY hKey,
DWORD dwIndex, DWORD dwIndex,
@ -959,6 +964,8 @@ FUNCTION: LONG RegEnumKeyExW (
LPDWORD lpcClass, LPDWORD lpcClass,
PFILETIME lpftLastWriteTime PFILETIME lpftLastWriteTime
) ; ) ;
ALIAS: RegEnumKeyEx RegEnumKeyExW
! : RegEnumKeyW ; ! : RegEnumKeyW ;
! : RegEnumValueA ; ! : RegEnumValueA ;
@ -1023,7 +1030,8 @@ ALIAS: RegQueryValueEx RegQueryValueExW
! : RegSetValueA ; ! : RegSetValueA ;
! : RegSetValueExA ; ! : RegSetValueExA ;
! : RegSetValueExW ; ! : RegSetValueExW ;
! : RegSetValueW ; FUNCTION: LONG RegSetValueExW ( HKEY hKey, LPCTSTR lpValueName, DWORD Reserved, DWORD dwType, BYTE* lpData, DWORD cbData ) ;
ALIAS: RegSetValueEx RegSetValueExW
! : RegUnLoadKeyA ; ! : RegUnLoadKeyA ;
! : RegUnLoadKeyW ; ! : RegUnLoadKeyW ;
! : RegisterEventSourceA ; ! : RegisterEventSourceA ;

View File

@ -1,5 +1,5 @@
USING: kernel windows.com windows.com.syntax windows.ole32 USING: kernel windows.com windows.com.syntax windows.ole32
alien alien.syntax tools.test libc alien.c-types windows.types alien alien.syntax tools.test libc alien.c-types
namespaces arrays continuations accessors math windows.com.wrapper namespaces arrays continuations accessors math windows.com.wrapper
windows.com.wrapper.private destructors effects compiler.units ; windows.com.wrapper.private destructors effects compiler.units ;
IN: windows.com.tests IN: windows.com.tests

View File

@ -71,7 +71,7 @@ ERROR: no-com-interface interface ;
: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
swap swap
[ [ second ] map ] [ [ second ] map ]
[ dup void? [ drop { } ] [ 1array ] if ] bi* [ dup void? [ drop { } ] [ name>> 1array ] if ] bi*
<effect> ; <effect> ;
: (define-word-for-function) ( function interface n -- ) : (define-word-for-function) ( function interface n -- )

View File

@ -87,9 +87,6 @@ ALIAS: SHGetFolderPath SHGetFolderPathW
FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ; FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ;
ALIAS: ShellExecute ShellExecuteW ALIAS: ShellExecute ShellExecuteW
: open-in-explorer ( dir -- )
[ f "open" ] dip absolute-path f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-directory ( n -- str ) : shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH <ushort-array> MAX_UNICODE_PATH <ushort-array>

View File

@ -608,6 +608,150 @@ CONSTANT: MF_HELP HEX: 4000
CONSTANT: MF_RIGHTJUSTIFY HEX: 4000 CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
CONSTANT: MF_MOUSESELECT HEX: 8000 CONSTANT: MF_MOUSESELECT HEX: 8000
CONSTANT: SPI_GETBEEP 1
CONSTANT: SPI_SETBEEP 2
CONSTANT: SPI_GETMOUSE 3
CONSTANT: SPI_SETMOUSE 4
CONSTANT: SPI_GETBORDER 5
CONSTANT: SPI_SETBORDER 6
CONSTANT: SPI_GETKEYBOARDSPEED 10
CONSTANT: SPI_SETKEYBOARDSPEED 11
CONSTANT: SPI_LANGDRIVER 12
CONSTANT: SPI_ICONHORIZONTALSPACING 13
CONSTANT: SPI_GETSCREENSAVETIMEOUT 14
CONSTANT: SPI_SETSCREENSAVETIMEOUT 15
CONSTANT: SPI_GETSCREENSAVEACTIVE 16
CONSTANT: SPI_SETSCREENSAVEACTIVE 17
CONSTANT: SPI_GETGRIDGRANULARITY 18
CONSTANT: SPI_SETGRIDGRANULARITY 19
CONSTANT: SPI_SETDESKWALLPAPER 20
CONSTANT: SPI_SETDESKPATTERN 21
CONSTANT: SPI_GETKEYBOARDDELAY 22
CONSTANT: SPI_SETKEYBOARDDELAY 23
CONSTANT: SPI_ICONVERTICALSPACING 24
CONSTANT: SPI_GETICONTITLEWRAP 25
CONSTANT: SPI_SETICONTITLEWRAP 26
CONSTANT: SPI_GETMENUDROPALIGNMENT 27
CONSTANT: SPI_SETMENUDROPALIGNMENT 28
CONSTANT: SPI_SETDOUBLECLKWIDTH 29
CONSTANT: SPI_SETDOUBLECLKHEIGHT 30
CONSTANT: SPI_GETICONTITLELOGFONT 31
CONSTANT: SPI_SETDOUBLECLICKTIME 32
CONSTANT: SPI_SETMOUSEBUTTONSWAP 33
CONSTANT: SPI_SETICONTITLELOGFONT 34
CONSTANT: SPI_GETFASTTASKSWITCH 35
CONSTANT: SPI_SETFASTTASKSWITCH 36
CONSTANT: SPI_SETDRAGFULLWINDOWS 37
CONSTANT: SPI_GETDRAGFULLWINDOWS 38
CONSTANT: SPI_GETFILTERKEYS 50
CONSTANT: SPI_SETFILTERKEYS 51
CONSTANT: SPI_GETTOGGLEKEYS 52
CONSTANT: SPI_SETTOGGLEKEYS 53
CONSTANT: SPI_GETMOUSEKEYS 54
CONSTANT: SPI_SETMOUSEKEYS 55
CONSTANT: SPI_GETSHOWSOUNDS 56
CONSTANT: SPI_SETSHOWSOUNDS 57
CONSTANT: SPI_GETSTICKYKEYS 58
CONSTANT: SPI_SETSTICKYKEYS 59
CONSTANT: SPI_GETACCESSTIMEOUT 60
CONSTANT: SPI_SETACCESSTIMEOUT 61
CONSTANT: SPI_GETSOUNDSENTRY 64
CONSTANT: SPI_SETSOUNDSENTRY 65
! WINVER >= 0x0400
CONSTANT: SPI_GETNONCLIENTMETRICS 41
CONSTANT: SPI_SETNONCLIENTMETRICS 42
CONSTANT: SPI_GETMINIMIZEDMETRICS 43
CONSTANT: SPI_SETMINIMIZEDMETRICS 44
CONSTANT: SPI_GETICONMETRICS 45
CONSTANT: SPI_SETICONMETRICS 46
CONSTANT: SPI_SETWORKAREA 47
CONSTANT: SPI_GETWORKAREA 48
CONSTANT: SPI_SETPENWINDOWS 49
CONSTANT: SPI_GETSERIALKEYS 62
CONSTANT: SPI_SETSERIALKEYS 63
CONSTANT: SPI_GETHIGHCONTRAST 66
CONSTANT: SPI_SETHIGHCONTRAST 67
CONSTANT: SPI_GETKEYBOARDPREF 68
CONSTANT: SPI_SETKEYBOARDPREF 69
CONSTANT: SPI_GETSCREENREADER 70
CONSTANT: SPI_SETSCREENREADER 71
CONSTANT: SPI_GETANIMATION 72
CONSTANT: SPI_SETANIMATION 73
CONSTANT: SPI_GETFONTSMOOTHING 74
CONSTANT: SPI_SETFONTSMOOTHING 75
CONSTANT: SPI_SETDRAGWIDTH 76
CONSTANT: SPI_SETDRAGHEIGHT 77
CONSTANT: SPI_SETHANDHELD 78
CONSTANT: SPI_GETLOWPOWERTIMEOUT 79
CONSTANT: SPI_GETPOWEROFFTIMEOUT 80
CONSTANT: SPI_SETLOWPOWERTIMEOUT 81
CONSTANT: SPI_SETPOWEROFFTIMEOUT 82
CONSTANT: SPI_GETLOWPOWERACTIVE 83
CONSTANT: SPI_GETPOWEROFFACTIVE 84
CONSTANT: SPI_SETLOWPOWERACTIVE 85
CONSTANT: SPI_SETPOWEROFFACTIVE 86
CONSTANT: SPI_SETCURSORS 87
CONSTANT: SPI_SETICONS 88
CONSTANT: SPI_GETDEFAULTINPUTLANG 89
CONSTANT: SPI_SETDEFAULTINPUTLANG 90
CONSTANT: SPI_SETLANGTOGGLE 91
CONSTANT: SPI_GETWINDOWSEXTENSION 92
CONSTANT: SPI_SETMOUSETRAILS 93
CONSTANT: SPI_GETMOUSETRAILS 94
CONSTANT: SPI_SETSCREENSAVERRUNNING 97
ALIAS: SPI_SCREENSAVERRUNNING SPI_SETSCREENSAVERRUNNING
! WIN32_WINNT >= 0x0400 || WIN32_WINDOWS > 0x0400
CONSTANT: SPI_GETMOUSEHOVERWIDTH 98
CONSTANT: SPI_SETMOUSEHOVERWIDTH 99
CONSTANT: SPI_GETMOUSEHOVERHEIGHT 100
CONSTANT: SPI_SETMOUSEHOVERHEIGHT 101
CONSTANT: SPI_GETMOUSEHOVERTIME 102
CONSTANT: SPI_SETMOUSEHOVERTIME 103
CONSTANT: SPI_GETWHEELSCROLLLINES 104
CONSTANT: SPI_SETWHEELSCROLLLINES 105
CONSTANT: SPI_GETSHOWIMEUI 110
CONSTANT: SPI_SETSHOWIMEUI 111
! WINVER >= 0x0500
CONSTANT: SPI_GETMOUSESPEED 112
CONSTANT: SPI_SETMOUSESPEED 113
CONSTANT: SPI_GETSCREENSAVERRUNNING 114
CONSTANT: SPI_GETACTIVEWINDOWTRACKING HEX: 1000
CONSTANT: SPI_SETACTIVEWINDOWTRACKING HEX: 1001
CONSTANT: SPI_GETMENUANIMATION HEX: 1002
CONSTANT: SPI_SETMENUANIMATION HEX: 1003
CONSTANT: SPI_GETCOMBOBOXANIMATION HEX: 1004
CONSTANT: SPI_SETCOMBOBOXANIMATION HEX: 1005
CONSTANT: SPI_GETLISTBOXSMOOTHSCROLLING HEX: 1006
CONSTANT: SPI_SETLISTBOXSMOOTHSCROLLING HEX: 1007
CONSTANT: SPI_GETGRADIENTCAPTIONS HEX: 1008
CONSTANT: SPI_SETGRADIENTCAPTIONS HEX: 1009
CONSTANT: SPI_GETMENUUNDERLINES HEX: 100A
CONSTANT: SPI_SETMENUUNDERLINES HEX: 100B
CONSTANT: SPI_GETACTIVEWNDTRKZORDER HEX: 100C
CONSTANT: SPI_SETACTIVEWNDTRKZORDER HEX: 100D
CONSTANT: SPI_GETHOTTRACKING HEX: 100E
CONSTANT: SPI_SETHOTTRACKING HEX: 100F
CONSTANT: SPI_GETFOREGROUNDLOCKTIMEOUT HEX: 2000
CONSTANT: SPI_SETFOREGROUNDLOCKTIMEOUT HEX: 2001
CONSTANT: SPI_GETACTIVEWNDTRKTIMEOUT HEX: 2002
CONSTANT: SPI_SETACTIVEWNDTRKTIMEOUT HEX: 2003
CONSTANT: SPI_GETFOREGROUNDFLASHCOUNT HEX: 2004
CONSTANT: SPI_SETFOREGROUNDFLASHCOUNT HEX: 2005
! SystemParamInfo Flags
CONSTANT: SPIF_UPDATEINIFILE 1
CONSTANT: SPIF_SENDWININICHANGE 2
ALIAS: SPIF_SENDCHANGE SPIF_SENDWININICHANGE
TYPEDEF: HANDLE HRAWINPUT TYPEDEF: HANDLE HRAWINPUT
: GET_RAWINPUT_CODE_WPARAM ( wParam -- n ) HEX: ff bitand ; inline : GET_RAWINPUT_CODE_WPARAM ( wParam -- n ) HEX: ff bitand ; inline
@ -1578,7 +1722,10 @@ FUNCTION: BOOL ShowWindow ( HWND hWnd, int nCmdShow ) ;
! FUNCTION: SwitchDesktop ! FUNCTION: SwitchDesktop
! FUNCTION: SwitchToThisWindow ! FUNCTION: SwitchToThisWindow
! FUNCTION: SystemParametersInfoA ! FUNCTION: SystemParametersInfoA
! FUNCTION: SystemParametersInfoW
FUNCTION: BOOL SystemParametersInfoW ( UINT uiAction, UINT uiParam, PVOID pvParam, UINT fWinIni ) ;
ALIAS: SystemParametersInfo SystemParametersInfoW
! FUNCTION: TabbedTextOutA ! FUNCTION: TabbedTextOutA
! FUNCTION: TabbedTextOutW ! FUNCTION: TabbedTextOutW
! FUNCTION: TileChildWindows ! FUNCTION: TileChildWindows

View File

@ -107,6 +107,7 @@ check_installed_programs() {
ensure_program_installed git ensure_program_installed git
ensure_program_installed wget curl ensure_program_installed wget curl
ensure_program_installed gcc ensure_program_installed gcc
ensure_program_installed g++ cl
ensure_program_installed make gmake ensure_program_installed make gmake
ensure_program_installed md5sum md5 ensure_program_installed md5sum md5
ensure_program_installed cut ensure_program_installed cut

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words words.symbol quotations io sequences strings vectors words words.symbol quotations io
@ -33,11 +33,19 @@ SYMBOL: auto-use?
[ "Added \"" "\" vocabulary to search path" surround note. ] bi [ "Added \"" "\" vocabulary to search path" surround note. ] bi
] [ create-in ] if ; ] [ create-in ] if ;
: ignore-forwards ( seq -- seq' )
[ forward-reference? not ] filter ;
: private? ( word -- ? ) vocabulary>> ".private" tail? ;
: ignore-privates ( seq -- seq' )
dup [ private? ] all? [ [ private? not ] filter ] unless ;
: no-word ( name -- newword ) : no-word ( name -- newword )
dup words-named [ forward-reference? not ] filter dup words-named ignore-forwards
dup length 1 = auto-use? get and dup ignore-privates dup length 1 = auto-use? get and
[ nip first no-word-restarted ] [ 2nip first no-word-restarted ]
[ <no-word-error> throw-restarts no-word-restarted ] [ drop <no-word-error> throw-restarts no-word-restarted ]
if ; if ;
: parse-word ( string -- word/number ) : parse-word ( string -- word/number )

View File

@ -14,5 +14,6 @@ IN: curses.tests
2000000 sleep 2000000 sleep
] with-curses ; ] with-curses ;
[ curses-ok? [
] [ hello-curses ] unit-test [ ] [ hello-curses ] unit-test
] when

View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings assocs byte-arrays
combinators continuations destructors fry io.encodings.8-bit combinators continuations destructors fry io.encodings.8-bit
io io.encodings.string io.encodings.utf8 kernel locals math io io.encodings.string io.encodings.utf8 kernel locals math
namespaces prettyprint sequences classes.struct namespaces prettyprint sequences classes.struct
strings threads curses.ffi ; strings threads curses.ffi unix.ffi ;
IN: curses IN: curses
SYMBOL: curses-windows SYMBOL: curses-windows
@ -19,6 +19,7 @@ ERROR: duplicate-window window ;
ERROR: unnamed-window window ; ERROR: unnamed-window window ;
ERROR: window-not-found window ; ERROR: window-not-found window ;
ERROR: curses-failed ; ERROR: curses-failed ;
ERROR: unsupported-curses-terminal ;
: get-window ( string -- window ) : get-window ( string -- window )
dup curses-windows get at* dup curses-windows get at*
@ -28,7 +29,11 @@ ERROR: curses-failed ;
: curses-error ( n -- ) ERR = [ curses-failed ] when ; : curses-error ( n -- ) ERR = [ curses-failed ] when ;
: curses-ok? ( -- ? )
{ 0 1 2 } [ isatty 0 = not ] all? ;
: with-curses ( quot -- ) : with-curses ( quot -- )
curses-ok? [ unsupported-curses-terminal ] unless
H{ } clone curses-windows [ H{ } clone curses-windows [
initscr curses-error initscr curses-error
[ [

View File

@ -1,5 +1,4 @@
USING: accessors kernel math math.order poker poker.private USING: accessors kernel math math.order poker poker.private tools.test ;
tools.test ;
IN: poker.tests IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test [ 134236965 ] [ "KD" >ckf ] unit-test

View File

@ -1,5 +1,4 @@
! Copyright (c) 2009 Aaron Schaefer. All rights reserved. ! Copyright (c) 2009 Aaron Schaefer, Doug Coleman. All rights reserved.
! Copyright (c) 2009 Doug Coleman.
! The contents of this file are licensed under the Simplified BSD License ! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt ! A copy of the license is available at http://factorcode.org/license.txt
USING: accessors arrays ascii assocs binary-search combinators USING: accessors arrays ascii assocs binary-search combinators

View File

@ -1,7 +1,7 @@
! Copyright (c) 2009 Aaron Schaefer. ! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays fry hints kernel math math.combinatorics USING: arrays byte-arrays fry kernel math math.combinatorics math.functions
math.functions math.parser math.primes project-euler.common sequences sets ; math.parser math.primes project-euler.common sequences sets ;
IN: project-euler.049 IN: project-euler.049
! http://projecteuler.net/index.php?section=problems&id=49 ! http://projecteuler.net/index.php?section=problems&id=49
@ -25,16 +25,6 @@ IN: project-euler.049
<PRIVATE <PRIVATE
: count-digits ( n -- byte-array )
10 <byte-array> [
'[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
] keep ;
HINTS: count-digits fixnum ;
: permutations? ( n m -- ? )
[ count-digits ] bi@ = ;
: collect-permutations ( seq -- seq ) : collect-permutations ( seq -- seq )
[ V{ } clone ] [ dup ] bi* [ [ V{ } clone ] [ dup ] bi* [
dupd '[ _ permutations? ] filter dupd '[ _ permutations? ] filter

View File

@ -0,0 +1,4 @@
USING: project-euler.070 tools.test ;
IN: project-euler.070.tests
[ 8319823 ] [ euler070 ] unit-test

View File

@ -0,0 +1,67 @@
! Copyright (c) 2010 Aaron Schaefer. All rights reserved.
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
USING: arrays assocs combinators.short-circuit kernel math math.combinatorics
math.functions math.primes math.ranges project-euler.common sequences ;
IN: project-euler.070
! http://projecteuler.net/index.php?section=problems&id=70
! DESCRIPTION
! -----------
! Euler's Totient function, φ(n) [sometimes called the phi function], is used
! to determine the number of positive numbers less than or equal to n which are
! relatively prime to n. For example, as 1, 2, 4, 5, 7, and 8, are all less
! than nine and relatively prime to nine, φ(9)=6. The number 1 is considered to
! be relatively prime to every positive number, so φ(1)=1.
! Interestingly, φ(87109)=79180, and it can be seen that 87109 is a permutation
! of 79180.
! Find the value of n, 1 < n < 10^(7), for which φ(n) is a permutation of n and
! the ratio n/φ(n) produces a minimum.
! SOLUTION
! --------
! For n/φ(n) to be minimised, φ(n) must be as close to n as possible; that is,
! we want to maximise φ(n). The minimal solution for n/φ(n) would be if n was
! prime giving n/(n-1) but since n-1 never is a permutation of n it cannot be
! prime.
! The next best thing would be if n only consisted of 2 prime factors close to
! (in this case) sqrt(10000000). Hence n = p1*p2 and we only need to search
! through a list of known prime pairs. In addition:
! φ(p1*p2) = p1*p2*(1-1/p1)(1-1/p2) = (p1-1)(p2-1)
! ...so we can compute φ(n) more efficiently.
<PRIVATE
! NOTE: ±1000 is an arbitrary range
: likely-prime-factors ( -- seq )
7 10^ sqrt >integer 1000 [ - ] [ + ] 2bi primes-between ; inline
: n-and-phi ( seq -- seq' )
#! ( seq = { p1, p2 } -- seq' = { n, φ(n) } )
[ product ] [ [ 1 - ] map product ] bi 2array ;
: fit-requirements? ( seq -- ? )
first2 { [ drop 7 10^ < ] [ permutations? ] } 2&& ;
: minimum-ratio ( seq -- n )
[ [ first2 / ] map [ infimum ] keep index ] keep nth first ;
PRIVATE>
: euler070 ( -- answer )
likely-prime-factors 2 all-combinations [ n-and-phi ] map
[ fit-requirements? ] filter minimum-ratio ;
! [ euler070 ] 100 ave-time
! 379 ms ave run time - 1.15 SD (100 trials)
SOLUTION: euler070

View File

@ -0,0 +1,4 @@
USING: project-euler.206 tools.test ;
IN: project-euler.206.tests
[ 1389019170 ] [ euler206 ] unit-test

View File

@ -0,0 +1,46 @@
! Copyright (c) 2010 Aaron Schaefer. All rights reserved.
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
USING: grouping kernel math math.ranges project-euler.common sequences ;
IN: project-euler.206
! http://projecteuler.net/index.php?section=problems&id=206
! DESCRIPTION
! -----------
! Find the unique positive integer whose square has the form
! 1_2_3_4_5_6_7_8_9_0, where each “_” is a single digit.
! SOLUTION
! --------
! Through mathematical analysis, we know that the number must end in 00, and
! the only way to get the last digits to be 900, is for our answer to end in
! 30 or 70.
<PRIVATE
! 1020304050607080900 sqrt, rounded up to the nearest 30 ending
CONSTANT: lo 1010101030
! 1929394959697989900 sqrt, rounded down to the nearest 70 ending
CONSTANT: hi 1389026570
: form-fitting? ( n -- ? )
number>digits 2 group [ first ] map
{ 1 2 3 4 5 6 7 8 9 0 } = ;
: candidates ( -- seq )
lo lo 40 + [ hi 100 <range> ] bi@ append ;
PRIVATE>
: euler206 ( -- answer )
candidates [ sq form-fitting? ] find-last nip ;
! [ euler206 ] 100 ave-time
! 321 ms ave run time - 8.33 SD (100 trials)
SOLUTION: euler206

View File

@ -1,49 +1,64 @@
! Copyright (C) 2009 Jon Harper. ! Copyright (c) 2009 Jon Harper.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: project-euler.common math kernel sequences math.functions math.ranges prettyprint io threads math.parser locals arrays namespaces ; USING: arrays io kernel locals math math.functions math.parser math.ranges
namespaces prettyprint project-euler.common sequences threads ;
IN: project-euler.255 IN: project-euler.255
! http://projecteuler.net/index.php?section=problems&id=255 ! http://projecteuler.net/index.php?section=problems&id=255
! DESCRIPTION ! DESCRIPTION
! ----------- ! -----------
! We define the rounded-square-root of a positive integer n as the square root of n rounded to the nearest integer.
! ! We define the rounded-square-root of a positive integer n as the square root
! The following procedure (essentially Heron's method adapted to integer arithmetic) finds the rounded-square-root of n: ! of n rounded to the nearest integer.
!
! Let d be the number of digits of the number n. ! The following procedure (essentially Heron's method adapted to integer
! If d is odd, set x_(0) = 2×10^((d-1)2). ! arithmetic) finds the rounded-square-root of n:
! If d is even, set x_(0) = 7×10^((d-2)2).
! Repeat: ! Let d be the number of digits of the number n.
! ! If d is odd, set x_(0) = 2×10^((d-1)2).
! until x_(k+1) = x_(k). ! If d is even, set x_(0) = 7×10^((d-2)2).
!
! Repeat: [see URL for figure ]
! until x_(k+1) = x_(k).
! As an example, let us find the rounded-square-root of n = 4321. ! As an example, let us find the rounded-square-root of n = 4321.
! n has 4 digits, so x_(0) = 7×10^((4-2)2) = 70. ! n has 4 digits, so x_(0) = 7×10^((4-2)2) = 70.
!
! Since x_(2) = x_(1), we stop here.
! So, after just two iterations, we have found that the rounded-square-root of 4321 is 66 (the actual square root is 65.7343137…).
!
! The number of iterations required when using this method is surprisingly low.
! For example, we can find the rounded-square-root of a 5-digit integer (10,000 ≤ n ≤ 99,999) with an average of 3.2102888889 iterations (the average value was rounded to 10 decimal places).
!
! Using the procedure described above, what is the average number of iterations required to find the rounded-square-root of a 14-digit number (10^(13) ≤ n < 10^(14))?
! Give your answer rounded to 10 decimal places.
!
! Note: The symbols ⌊x⌋ and ⌈x⌉ represent the floor function and ceiling function respectively.
!
<PRIVATE
: round-to-10-decimals ( a -- b ) 1.0e10 * round 1.0e10 / ; ! [ see URL for figure ]
! Since x_(2) = x_(1), we stop here.
! So, after just two iterations, we have found that the rounded-square-root of
! 4321 is 66 (the actual square root is 65.7343137…).
! The number of iterations required when using this method is surprisingly low.
! For example, we can find the rounded-square-root of a 5-digit integer
! (10,000 ≤ n ≤ 99,999) with an average of 3.2102888889 iterations (the average
! value was rounded to 10 decimal places).
! Using the procedure described above, what is the average number of iterations
! required to find the rounded-square-root of a 14-digit number
! (10^(13) ≤ n < 10^(14))? Give your answer rounded to 10 decimal places.
! Note: The symbols ⌊x⌋ and ⌈x⌉ represent the floor function and ceiling
! function respectively.
! SOLUTION
! --------
<PRIVATE
! same as produce, but outputs the sum instead of the sequence of results ! same as produce, but outputs the sum instead of the sequence of results
: produce-sum ( id pred quot -- sum ) : produce-sum ( id pred quot -- sum )
[ 0 ] 2dip [ [ dip swap ] curry ] [ [ dip + ] curry ] bi* while ; inline [ 0 ] 2dip [ [ dip swap ] curry ] [ [ dip + ] curry ] bi* while ; inline
: x0 ( i -- x0 ) : x0 ( i -- x0 )
number-length dup even? number-length dup even?
[ 2 - 2 / 10 swap ^ 7 * ] [ 2 - 2 / 10 swap ^ 7 * ]
[ 1 - 2 / 10 swap ^ 2 * ] if ; [ 1 - 2 / 10 swap ^ 2 * ] if ;
: ⌈a/b⌉ ( a b -- ⌈a/b⌉ ) : ⌈a/b⌉ ( a b -- ⌈a/b⌉ )
[ 1 - + ] keep /i ; [ 1 - + ] keep /i ;
@ -56,38 +71,37 @@ IN: project-euler.255
DEFER: iteration# DEFER: iteration#
! Gives the number of iterations when xk+1 has the same value for all a<=i<=n ! Gives the number of iterations when xk+1 has the same value for all a<=i<=n
:: (iteration#) ( i xi a b -- # ) :: (iteration#) ( i xi a b -- # )
a xi xk+1 dup xi = a xi xk+1 dup xi =
[ drop i b a - 1 + * ] [ drop i b a - 1 + * ]
[ i 1 + swap a b iteration# ] if ; [ i 1 + swap a b iteration# ] if ;
! Gives the number of iterations in the general case by breaking into intervals ! Gives the number of iterations in the general case by breaking into intervals
! in which xk+1 is the same. ! in which xk+1 is the same.
:: iteration# ( i xi a b -- # ) :: iteration# ( i xi a b -- # )
a a
a xi next-multiple a xi next-multiple
[ dup b < ] [ dup b < ]
[ [
! set up the values for the next iteration ! set up the values for the next iteration
[ nip [ 1 + ] [ xi + ] bi ] 2keep [ nip [ 1 + ] [ xi + ] bi ] 2keep
! set up the arguments for (iteration#) ! set up the arguments for (iteration#)
[ i xi ] 2dip (iteration#) [ i xi ] 2dip (iteration#)
] produce-sum ] produce-sum
! deal with the last numbers ! deal with the last numbers
[ drop b [ i xi ] 2dip (iteration#) ] dip [ drop b [ i xi ] 2dip (iteration#) ] dip
+ ; + ;
: 10^ ( a -- 10^a ) 10 swap ^ ; inline : (euler255) ( a b -- answer )
: (euler255) ( a b -- answer )
[ 10^ ] bi@ 1 - [ 10^ ] bi@ 1 -
[ [ drop x0 1 swap ] 2keep iteration# ] 2keep [ [ drop x0 1 swap ] 2keep iteration# ] 2keep
swap - 1 + /f ; swap - 1 + /f ;
PRIVATE> PRIVATE>
: euler255 ( -- answer ) : euler255 ( -- answer )
13 14 (euler255) round-to-10-decimals ; 13 14 (euler255) 10 nth-place ;
! [ euler255 ] gc time
! Running time: 37.468911341 seconds
SOLUTION: euler255 SOLUTION: euler255

View File

@ -1,10 +1,11 @@
! Copyright (c) 2007-2009 Aaron Schaefer. ! Copyright (c) 2007-2010 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! The contents of this file are licensed under the Simplified BSD License
USING: accessors arrays kernel lists make math math.functions math.matrices ! A copy of the license is available at http://factorcode.org/license.txt
math.primes.miller-rabin math.order math.parser math.primes.factors USING: accessors arrays byte-arrays fry hints kernel lists make math
math.primes.lists math.ranges math.ratios namespaces parser prettyprint math.functions math.matrices math.order math.parser math.primes.factors
quotations sequences sorting strings unicode.case vocabs vocabs.parser math.primes.lists math.primes.miller-rabin math.ranges math.ratios
words ; namespaces parser prettyprint quotations sequences sorting strings
unicode.case vocabs vocabs.parser words ;
IN: project-euler.common IN: project-euler.common
! A collection of words used by more than one Project Euler solution ! A collection of words used by more than one Project Euler solution
@ -19,12 +20,13 @@ IN: project-euler.common
! mediant - #71, #73 ! mediant - #71, #73
! nth-prime - #7, #69 ! nth-prime - #7, #69
! nth-triangle - #12, #42 ! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92, #206
! palindrome? - #4, #36, #55 ! palindrome? - #4, #36, #55
! pandigital? - #32, #38 ! pandigital? - #32, #38
! pentagonal? - #44, #45 ! pentagonal? - #44, #45
! penultimate - #69, #71 ! penultimate - #69, #71
! propagate-all - #18, #67 ! propagate-all - #18, #67
! permutations? - #49, #70
! sum-proper-divisors - #21 ! sum-proper-divisors - #21
! tau* - #12 ! tau* - #12
! [uad]-transform - #39, #75 ! [uad]-transform - #39, #75
@ -38,6 +40,13 @@ IN: project-euler.common
<PRIVATE <PRIVATE
: count-digits ( n -- byte-array )
10 <byte-array> [
'[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
] keep ;
HINTS: count-digits fixnum ;
: max-children ( seq -- seq ) : max-children ( seq -- seq )
[ dup length 1 - iota [ nth-pair max , ] with each ] { } make ; [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
@ -83,6 +92,9 @@ PRIVATE>
[ [ 10 * ] [ 1 + ] bi* ] while 2nip [ [ 10 * ] [ 1 + ] bi* ] while 2nip
] if-zero ; ] if-zero ;
: nth-place ( x n -- y )
10^ [ * round >integer ] keep /f ;
: nth-prime ( n -- n ) : nth-prime ( n -- n )
1 - lprimes lnth ; 1 - lprimes lnth ;
@ -107,6 +119,9 @@ PRIVATE>
reverse [ first dup ] [ rest ] bi reverse [ first dup ] [ rest ] bi
[ propagate dup ] map nip reverse swap suffix ; [ propagate dup ] map nip reverse swap suffix ;
: permutations? ( n m -- ? )
[ count-digits ] bi@ = ;
: sum-divisors ( n -- sum ) : sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu. ! Copyright (c) 2007-2010 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@ -14,18 +14,19 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.051 project-euler.052 project-euler.053 project-euler.049 project-euler.050 project-euler.051 project-euler.052
project-euler.054 project-euler.055 project-euler.056 project-euler.057 project-euler.053 project-euler.054 project-euler.055 project-euler.056
project-euler.058 project-euler.059 project-euler.062 project-euler.063 project-euler.057 project-euler.058 project-euler.059 project-euler.062
project-euler.065 project-euler.067 project-euler.069 project-euler.071 project-euler.063 project-euler.065 project-euler.067 project-euler.069
project-euler.072 project-euler.073 project-euler.074 project-euler.075 project-euler.070 project-euler.071 project-euler.072 project-euler.073
project-euler.076 project-euler.079 project-euler.081 project-euler.085 project-euler.074 project-euler.075 project-euler.076 project-euler.079
project-euler.092 project-euler.097 project-euler.099 project-euler.100 project-euler.081 project-euler.085 project-euler.089 project-euler.092
project-euler.102 project-euler.112 project-euler.116 project-euler.117 project-euler.097 project-euler.099 project-euler.100 project-euler.102
project-euler.124 project-euler.134 project-euler.148 project-euler.150 project-euler.112 project-euler.116 project-euler.117 project-euler.124
project-euler.151 project-euler.164 project-euler.169 project-euler.173 project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.175 project-euler.186 project-euler.188 project-euler.190 project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.203 project-euler.215 ; project-euler.186 project-euler.188 project-euler.190 project-euler.203
project-euler.206 project-euler.215 project-euler.255 ;
IN: project-euler IN: project-euler
<PRIVATE <PRIVATE