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

Merge remote-tracking branch 'origin' into modern-harvey2

modern-harvey2
Doug Coleman 2018-03-11 00:44:10 -06:00
parent c7f12617a6 8c6925294f
commit e7cd3e3635
11 changed files with 399 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Nmakefile
View File

@ -1,10 +1,32 @@
!IF !DEFINED(VERSION)
VERSION = version-missing
VERSION = 0.98
# Crazy hack to do shell commands
# We do it in Nmakefile because that way we don't have to invoke build through build.cmd
# and we can just do ``nmake /f Nmakefile x86-64-vista`` or similar
# and we still get the git branch, id, etc
!IF [git describe --all > git-describe.tmp] == 0
GIT_DESCRIBE = \
!INCLUDE <git-describe.tmp>
!IF [rm git-describe.tmp] == 0
!ENDIF
!ENDIF
!IF !DEFINED(GIT_LABEL)
GIT_LABEL = git-label-missing
!IF [git rev-parse HEAD > git-id.tmp] == 0
GIT_ID = \
!INCLUDE <git-id.tmp>
!IF [rm git-id.tmp] == 0
!ENDIF
!ENDIF
!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0
GIT_BRANCH = \
!INCLUDE <git-branch.tmp>
!IF [rm git-branch.tmp] == 0
!ENDIF
!ENDIF
GIT_LABEL = $(GIT_DESCRIBE)-$(GIT_ID)
!IF DEFINED(PLATFORM)

10
build.cmd
View File

@ -1,10 +1,11 @@
@echo off
setlocal
: Fun syntax
for /f %%x in ('git describe --all') do set GIT_DESCRIBE=%%x
for /f %%y in ('git rev-parse HEAD') do set GIT_ID=%%y
: Check which branch we are on, or just assume master if we are not in a git repository
for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z
if %GIT_BRANCH% =="" (
GIT_BRANCH = "master"
)
if "%1"=="/?" (
goto usage
@ -34,9 +35,6 @@ if not errorlevel 1 (
) else goto nocl
)
set git_label=%GIT_DESCRIBE%-%GIT_ID%
set version=0.98
echo Deleting staging images from temp/...
del temp\staging.*.image

1
extra/crontab/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

22
extra/crontab/crontab-tests.factor Normal file
View File

@ -0,0 +1,22 @@
USING: calendar crontab kernel tools.test ;
{
T{ timestamp
{ year 2018 }
{ month 3 }
{ day 9 }
{ hour 12 }
{ minute 23 }
{ gmt-offset T{ duration { hour -8 } } }
}
} [
"23 0-20/2 * * *" parse-cronentry
T{ timestamp
{ year 2018 }
{ month 3 }
{ day 9 }
{ hour 12 }
{ minute 6 }
{ gmt-offset T{ duration { hour -8 } } }
} [ next-time-after ] keep
] unit-test

104
extra/crontab/crontab.factor Normal file
View File

@ -0,0 +1,104 @@
! Copyright (C) 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays ascii assocs calendar calendar.english
calendar.private combinators io kernel literals locals math
math.order math.parser math.ranges sequences splitting ;
IN: crontab
:: parse-value ( value quot: ( value -- value' ) seq -- value )
value {
{ [ CHAR: , over member? ] [
"," split [ quot seq parse-value ] map concat ] }
{ [ dup "*" = ] [ drop seq ] }
{ [ CHAR: / over member? ] [
"/" split1 [ quot seq parse-value 0 over length 1 - ] dip
string>number <range> swap nths ] }
{ [ CHAR: - over member? ] [
"-" split1 quot bi@ [a,b] ] }
[ quot call 1array ]
} cond ; inline recursive
: parse-day ( str -- n )
dup string>number [ ] [
>lower $[ day-abbreviations3 [ >lower ] map ] index
] ?if ;
: parse-month ( str -- n )
dup string>number [ ] [
>lower $[ month-abbreviations [ >lower ] map ] index
] ?if ;
TUPLE: cronentry minutes hours days months days-of-week command ;
CONSTANT: aliases H{
{ "@yearly" "0 0 1 1 *" }
{ "@annually" "0 0 1 1 *" }
{ "@monthly" "0 0 1 * *" }
{ "@weekly" "0 0 * * 0" }
{ "@daily" "0 0 * * *" }
{ "@midnight" "0 0 * * *" }
{ "@hourly" "0 * * * *" }
}
: parse-cronentry ( entry -- cronentry )
" " split1 [ aliases ?at drop ] dip " " glue
" " split1 " " split1 " " split1 " " split1 " " split1 {
[ [ string>number ] T{ range f 0 60 1 } parse-value ]
[ [ string>number ] T{ range f 0 24 1 } parse-value ]
[ [ string>number ] T{ range f 0 31 1 } parse-value ]
[ [ parse-month ] T{ range f 0 12 1 } parse-value ]
[ [ parse-day ] T{ range f 0 7 1 } parse-value ]
[ ]
} spread cronentry boa ;
:: next-time-after ( cronentry timestamp -- )
timestamp month>> :> month
cronentry months>> [ month >= ] find nip [
dup month = [ drop f ] [ timestamp month<< t ] if
] [
timestamp cronentry months>> first >>month 1 +year
] if* [ cronentry timestamp next-time-after ] when
timestamp hour>> :> hour
cronentry hours>> [ hour >= ] find nip [
dup hour = [ drop f ] [
timestamp hour<< 0 timestamp minute<< t
] if
] [
timestamp cronentry hours>> first >>hour 1 +day
] if* [ cronentry timestamp next-time-after ] when
timestamp minute>> :> minute
cronentry minutes>> [ minute >= ] find nip [
dup minute = [ drop f ] [ timestamp minute<< t ] if
] [
timestamp cronentry minutes>> first >>minute 1 +hour
] if* [ cronentry timestamp next-time-after ] when
timestamp day-of-week :> weekday
cronentry days-of-week>> [ weekday >= ] find nip [
cronentry days-of-week>> first 7 +
] unless* weekday -
timestamp day>> :> day
cronentry days>> [ day >= ] find nip [
day -
] [
timestamp 1 months time+
cronentry days>> first >>day
day-of-year timestamp day-of-year -
] if*
min [
timestamp swap +day drop
cronentry timestamp next-time-after
] unless-zero ;
: next-time ( cronentry -- timestamp )
now 0 >>second [ next-time-after ] keep ;
: parse-crontab ( -- entries )
lines [ [ f ] [ parse-cronentry ] if-empty ] map harvest ;

1
extra/crontab/summary.txt Normal file
View File

@ -0,0 +1 @@
Parser for crontab files

1
extra/game-of-life/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

213
extra/game-of-life/game-of-life.factor Normal file
View File

@ -0,0 +1,213 @@
! Copyright (C) 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays assocs bit-arrays calendar
colors.constants combinators combinators.short-circuit fry
kernel kernel.private locals math math.order math.private
math.ranges namespaces opengl random sequences sequences.private
timers ui ui.commands ui.gadgets ui.gadgets.toolbar
ui.gadgets.tracks ui.gestures ui.render words ;
IN: game-of-life
: make-grid ( rows cols -- grid )
'[ _ <bit-array> ] replicate ;
: grid-dim ( grid -- rows cols )
[ length ] [ first length ] bi ;
:: wraparound ( x min max -- y )
x min fixnum< [ max ] [ x max fixnum> min x ? ] if ; inline
:: count-neighbors ( grid -- counts )
grid grid-dim { fixnum fixnum } declare :> ( rows cols )
rows <iota> [| j |
cols <iota> [| i |
{ -1 0 1 } [
{ -1 0 1 } [
2dup [ 0 eq? ] both? [ 2drop f ] [
[ i fixnum+fast 0 cols 1 - wraparound ]
[ j fixnum+fast 0 rows 1 - wraparound ] bi*
{ fixnum fixnum } declare grid
{ array } declare nth-unsafe
{ bit-array } declare nth-unsafe
] if
] with count
] map-sum
] map
] map ;
:: next-step ( grid -- )
grid count-neighbors :> neighbors
grid [| row j |
row [| cell i |
i j neighbors
{ array } declare nth-unsafe
{ array } declare nth-unsafe
cell [
2 3 between? i j grid
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] [
3 = [
t i j grid
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] when
] if
] each-index
] each-index ;
TUPLE: grid-gadget < gadget grid size timer ;
: <grid-gadget> ( grid -- gadget )
grid-gadget new
swap >>grid
20 >>size
dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ]
f 1/5 seconds <timer> >>timer ;
M: grid-gadget ungraft*
[ timer>> stop-timer ] [ call-next-method ] bi ;
M: grid-gadget pref-dim*
[ grid>> grid-dim swap ] [ size>> '[ _ * ] bi@ 1 + 2array ] bi ;
:: update-grid ( gadget -- )
gadget dim>> first2 :> ( w h )
gadget size>> :> size
h w [ size /i ] bi@ :> ( new-rows new-cols )
gadget grid>> :> grid
grid grid-dim :> ( rows cols )
rows new-rows = not
cols new-cols = not or [
new-rows new-cols make-grid :> new-grid
rows new-rows min <iota> [| j |
cols new-cols min <iota> [| i |
i j grid nth nth
i j new-grid nth set-nth
] each
] each
new-grid gadget grid<<
] when ;
:: draw-cells ( gadget -- )
COLOR: black gl-color
gadget size>> :> size
gadget grid>> [| row j |
row [| cell i |
cell [
i j [ size * ] bi@ 2array
{ size size } gl-fill-rect
] when
] each-index
] each-index ;
:: draw-lines ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
COLOR: gray gl-color
cols rows [ size * ] bi@ :> ( w h )
rows [0,b] [| j |
j size * :> y
{ 0 y } { w y } gl-line
cols [0,b] [| i |
i size * :> x
{ x 0 } { x h } gl-line
] each
] each ;
M: grid-gadget draw-gadget*
[ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
SYMBOL: last-click
:: on-click ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
i 0 cols 1 - between?
j 0 rows 1 - between? and [
i j gadget grid>> nth
[ not dup last-click set ] change-nth
] when gadget relayout-1 ;
:: on-drag ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
i 0 cols 1 - between?
j 0 rows 1 - between? and [
last-click get i j gadget grid>> nth set-nth
] when gadget relayout-1 ;
: on-scroll ( gadget -- )
[
scroll-direction get second {
{ [ dup 0 > ] [ -2 ] }
{ [ dup 0 < ] [ 2 ] }
[ 0 ]
} cond nip + 4 30 clamp
] change-size relayout-1 ;
:: com-play ( gadget -- )
gadget timer>> thread>> [
gadget timer>> start-timer
] unless ;
:: com-step ( gadget -- )
gadget grid>> next-step
gadget relayout-1 ;
:: com-stop ( gadget -- )
gadget timer>> thread>> [
gadget timer>> stop-timer
] when ;
:: com-clear ( gadget -- )
gadget grid>> [ clear-bits ] each
gadget relayout-1 ;
:: com-random ( gadget -- )
gadget grid>> [
[ length>> ] [ underlying>> length random-bytes ] bi
bit-array boa
] map! drop gadget relayout-1 ;
:: com-glider ( gadget -- )
gadget grid>> :> grid
{ { 2 1 } { 3 2 } { 1 3 } { 2 3 } { 3 3 } }
[ first2 grid nth t -rot set-nth ] each
gadget relayout-1 ;
grid-gadget "toolbar" f {
{ T{ key-down { sym "1" } } com-play }
{ T{ key-down { sym "2" } } com-stop }
{ T{ key-down { sym "3" } } com-clear }
{ T{ key-down { sym "4" } } com-random }
{ T{ key-down { sym "5" } } com-glider }
{ T{ key-down { sym "6" } } com-step }
} define-command-map
grid-gadget "gestures" [
{
{ T{ key-down f { A+ } "F" } [ toggle-fullscreen ] }
{ T{ button-down { # 1 } } [ on-click ] }
{ T{ drag { # 1 } } [ on-drag ] }
{ mouse-scroll [ on-scroll ] }
} assoc-union
] change-word-prop
TUPLE: life-gadget < track ;
: <life-gadget> ( -- gadget )
vertical life-gadget new-track
20 20 make-grid <grid-gadget>
[ <toolbar> format-toolbar f track-add ]
[ 1 track-add ] bi ;
M: life-gadget focusable-child* children>> second ;
MAIN-WINDOW: life-window {
{ title "Game of Life" }
} <life-gadget> >>gadgets ;

1
extra/game-of-life/summary.txt Normal file
View File

@ -0,0 +1 @@
Conway's Game of Life

1
extra/game-of-life/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

69
extra/minesweeper/minesweeper.factor
View File

@ -45,17 +45,16 @@ TUPLE: cell #adjacent mined? state ;
: place-mines ( cells n -- cells )
[ dup unmined-cell t >>mined? drop ] times ;
: adjacent-mines ( cells row col -- #mines )
neighbors [
first2 [ + ] bi-curry@ bi* cell-at
[ mined?>> ] [ f ] if*
] with with with count ;
:: count-neighbors ( cells row col quot: ( cell -- ? ) -- n )
cells neighbors [
first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if*
] with count ; inline
: adjacent-flags ( cells row col -- #mines )
neighbors [
first2 [ + ] bi-curry@ bi* cell-at
[ state>> +flagged+ = ] [ f ] if*
] with with with count ;
: adjacent-mines ( cells row col -- #mines )
[ mined?>> ] count-neighbors ;
: adjacent-flags ( cells row col -- #flags )
[ state>> +flagged+ = ] count-neighbors ;
:: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... )
cells |[ row |
@ -253,6 +252,19 @@ M: grid-gadget draw-gadget*
[ draw-cells ]
} cleave ;
:: on-grid ( gadget quot: ( cells row col -- ? ) -- )
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col quot call [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ; inline
:: on-click ( gadget -- )
gadget hand-rel first2 :> ( w h )
h 58 < [
@ -261,42 +273,11 @@ M: grid-gadget draw-gadget*
gadget [ reset-cells ] change-cells
f >>start f >>end drop
] when
] [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col click-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] if gadget relayout-1 ;
] when gadget [ click-cell-at ] on-grid ;
:: on-mark ( gadget -- )
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col mark-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ;
: on-mark ( gadget -- ) [ mark-cell-at ] on-grid ;
:: on-open ( gadget -- )
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col open-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ;
: on-open ( gadget -- ) [ open-cell-at ] on-grid ;
: new-game ( gadget rows cols mines -- )
[ make-cells ] dip place-mines update-counts >>cells