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

Nmakefile

@@ -1,10 +1,32 @@
-!IF !DEFINED(VERSION)
+VERSION = 0.98
-VERSION = version-missing
+
+# 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)
+!IF [git rev-parse HEAD > git-id.tmp] == 0
-GIT_LABEL = git-label-missing
+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)
 

build.cmd

@@ -1,10 +1,11 @@
 @echo off
 setlocal
 
-: Fun syntax
+: Check which branch we are on, or just assume master if we are not in a git repository
-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
 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
 

extra/crontab/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/crontab/crontab-tests.factor

@@ -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

extra/crontab/crontab.factor

@@ -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 ;

extra/crontab/summary.txt

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

extra/game-of-life/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/game-of-life/game-of-life.factor

@@ -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 ;

extra/game-of-life/summary.txt

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

extra/game-of-life/tags.txt

@@ -0,0 +1 @@
+demos

extra/minesweeper/minesweeper.factor

@@ -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 )
+:: count-neighbors ( cells row col quot: ( cell -- ? ) -- n )
-    neighbors [
+    cells neighbors [
-        first2 [ + ] bi-curry@ bi* cell-at
+        first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if*
-        [ mined?>> ] [ f ] if*
+    ] with count ; inline
-    ] with with with count ;
 
-: adjacent-flags ( cells row col -- #mines )
+: adjacent-mines ( cells row col -- #mines )
-    neighbors [
+    [ mined?>> ] count-neighbors ;
-        first2 [ + ] bi-curry@ bi* cell-at
+
-        [ state>> +flagged+ = ] [ f ] if*
+: adjacent-flags ( cells row col -- #flags )
-    ] with with with count ;
+    [ 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
-    ] [
+    ] when gadget [ click-cell-at ] on-grid ;
-        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 ;
 
-:: on-mark ( gadget -- )
+: on-mark ( gadget -- ) [ mark-cell-at ] on-grid ;
-    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-open ( gadget -- )
+: on-open ( gadget -- ) [ open-cell-at ] on-grid ;
-    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 ;
 
 : new-game ( gadget rows cols mines -- )
     [ make-cells ] dip place-mines update-counts >>cells