case/cond
parent
acf6132389
commit
484f765566
|
@ -30,7 +30,7 @@ MEMO: fn ( n -- x )
|
||||||
{
|
{
|
||||||
{ [ dup 2 < ] [ drop 1 ] }
|
{ [ dup 2 < ] [ drop 1 ] }
|
||||||
{ [ dup odd? ] [ 2/ fn ] }
|
{ [ dup odd? ] [ 2/ fn ] }
|
||||||
{ [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] }
|
[ 2/ [ fn ] [ 1- fn + ] bi + ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: euler169 ( -- result )
|
: euler169 ( -- result )
|
||||||
|
|
|
@ -44,7 +44,7 @@ IN: project-euler.175
|
||||||
{
|
{
|
||||||
{ [ dup integer? ] [ 1- 0 add-bits ] }
|
{ [ dup integer? ] [ 1- 0 add-bits ] }
|
||||||
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
|
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
|
||||||
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
|
[ [ 1 mod compute ] 2keep >integer 0 add-bits ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
|
@ -113,7 +113,7 @@ M: array noise [ noise ] map vsum ;
|
||||||
noise first2 {
|
noise first2 {
|
||||||
{ [ over 4 <= ] [ >r drop 0 r> ] }
|
{ [ over 4 <= ] [ >r drop 0 r> ] }
|
||||||
{ [ over 15 >= ] [ >r 2 * r> ] }
|
{ [ over 15 >= ] [ >r 2 * r> ] }
|
||||||
{ [ t ] [ ] }
|
[ ]
|
||||||
} cond
|
} cond
|
||||||
{
|
{
|
||||||
! short words are easier to read
|
! short words are easier to read
|
||||||
|
@ -123,7 +123,7 @@ M: array noise [ noise ] map vsum ;
|
||||||
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }
|
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }
|
||||||
{ [ dup 20 >= ] [ >r 5/3 * r> ] }
|
{ [ dup 20 >= ] [ >r 5/3 * r> ] }
|
||||||
{ [ dup 15 >= ] [ >r 3/2 * r> ] }
|
{ [ dup 15 >= ] [ >r 3/2 * r> ] }
|
||||||
{ [ t ] [ ] }
|
[ ]
|
||||||
} cond noise-factor ;
|
} cond noise-factor ;
|
||||||
|
|
||||||
GENERIC: word-noise-factor ( word -- factor )
|
GENERIC: word-noise-factor ( word -- factor )
|
||||||
|
|
|
@ -9,7 +9,7 @@ IN: rot13
|
||||||
{
|
{
|
||||||
{ [ dup letter? ] [ CHAR: a rotate ] }
|
{ [ dup letter? ] [ CHAR: a rotate ] }
|
||||||
{ [ dup LETTER? ] [ CHAR: A rotate ] }
|
{ [ dup LETTER? ] [ CHAR: A rotate ] }
|
||||||
{ [ t ] [ ] }
|
[ ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: rot13 ( string -- string ) [ rot-letter ] map ;
|
: rot13 ( string -- string ) [ rot-letter ] map ;
|
||||||
|
|
|
@ -65,7 +65,7 @@ GENERIC: (serialize) ( obj -- )
|
||||||
read1 {
|
read1 {
|
||||||
{ [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
|
{ [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
|
||||||
{ [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
|
{ [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
|
||||||
{ [ t ] [ read be> ] }
|
[ read be> ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: serialize-shared ( obj quot -- )
|
: serialize-shared ( obj quot -- )
|
||||||
|
@ -183,7 +183,7 @@ M: word (serialize) ( obj -- )
|
||||||
{
|
{
|
||||||
{ [ dup t eq? ] [ serialize-true ] }
|
{ [ dup t eq? ] [ serialize-true ] }
|
||||||
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
|
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
|
||||||
{ [ t ] [ serialize-word ] }
|
[ serialize-word ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: wrapper (serialize) ( obj -- )
|
M: wrapper (serialize) ( obj -- )
|
||||||
|
|
|
@ -56,9 +56,9 @@ SYMBOL: data-mode
|
||||||
"220 OK\r\n" write flush t
|
"220 OK\r\n" write flush t
|
||||||
] }
|
] }
|
||||||
{ [ data-mode get ] [ dup global [ print ] bind t ] }
|
{ [ data-mode get ] [ dup global [ print ] bind t ] }
|
||||||
{ [ t ] [
|
[
|
||||||
"500 ERROR\r\n" write flush t
|
"500 ERROR\r\n" write flush t
|
||||||
] }
|
]
|
||||||
} cond nip [ process ] when ;
|
} cond nip [ process ] when ;
|
||||||
|
|
||||||
: mock-smtp-server ( port -- )
|
: mock-smtp-server ( port -- )
|
||||||
|
|
|
@ -70,7 +70,7 @@ LOG: smtp-response DEBUG
|
||||||
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
|
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
|
||||||
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
|
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
|
||||||
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
|
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
|
||||||
{ [ t ] [ "unknown error" throw ] }
|
[ "unknown error" throw ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: multiline? ( response -- boolean )
|
: multiline? ( response -- boolean )
|
||||||
|
|
|
@ -306,7 +306,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
|
||||||
{ [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
|
{ [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
|
||||||
{ [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
|
{ [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
|
||||||
{ [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
|
{ [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
|
||||||
{ [ t ] [ 2drop white ] }
|
[ 2drop white ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: plot-bitmap-bits ( bitmap point byte bit -- )
|
: plot-bitmap-bits ( bitmap point byte bit -- )
|
||||||
|
|
|
@ -32,7 +32,7 @@ DEFER: search
|
||||||
{ [ 3dup nip row-contains? ] [ 3drop ] }
|
{ [ 3dup nip row-contains? ] [ 3drop ] }
|
||||||
{ [ 3dup drop col-contains? ] [ 3drop ] }
|
{ [ 3dup drop col-contains? ] [ 3drop ] }
|
||||||
{ [ 3dup box-contains? ] [ 3drop ] }
|
{ [ 3dup box-contains? ] [ 3drop ] }
|
||||||
{ [ t ] [ assume ] }
|
[ assume ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
|
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
|
||||||
|
@ -62,7 +62,7 @@ DEFER: search
|
||||||
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
|
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
|
||||||
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
|
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
|
||||||
{ [ 2dup board> ] [ >r 1+ r> search ] }
|
{ [ 2dup board> ] [ >r 1+ r> search ] }
|
||||||
{ [ t ] [ solve ] }
|
[ solve ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: sudoku ( board -- )
|
: sudoku ( board -- )
|
||||||
|
|
|
@ -35,7 +35,7 @@ unicode.categories ;
|
||||||
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
|
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
|
||||||
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
|
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
|
||||||
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
|
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
|
||||||
{ [ t ] [ 2drop 1 ] }
|
[ 2drop 1 ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: score ( full fuzzy -- n )
|
: score ( full fuzzy -- n )
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: tools.vocabs.browser
|
||||||
{
|
{
|
||||||
{ [ dup not ] [ drop "" ] }
|
{ [ dup not ] [ drop "" ] }
|
||||||
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
|
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
|
||||||
{ [ t ] [ drop "[Loaded]" ] }
|
[ drop "[Loaded]" ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: write-status ( vocab -- )
|
: write-status ( vocab -- )
|
||||||
|
|
|
@ -216,7 +216,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
||||||
{ [ ".test" ?tail ] [ t ] }
|
{ [ ".test" ?tail ] [ t ] }
|
||||||
{ [ "raptor" ?head ] [ t ] }
|
{ [ "raptor" ?head ] [ t ] }
|
||||||
{ [ dup "tools.deploy.app" = ] [ t ] }
|
{ [ dup "tools.deploy.app" = ] [ t ] }
|
||||||
{ [ t ] [ f ] }
|
[ f ]
|
||||||
} cond nip ;
|
} cond nip ;
|
||||||
|
|
||||||
: filter-dangerous ( seq -- seq' )
|
: filter-dangerous ( seq -- seq' )
|
||||||
|
|
|
@ -73,7 +73,7 @@ M: object add-breakpoint ;
|
||||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
{ [ dup primitive? ] [ execute break ] }
|
{ [ dup primitive? ] [ execute break ] }
|
||||||
{ [ t ] [ word-def (step-into-quot) ] }
|
[ word-def (step-into-quot) ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
\ (step-into-execute) t "step-into?" set-word-prop
|
\ (step-into-execute) t "step-into?" set-word-prop
|
||||||
|
@ -153,7 +153,7 @@ SYMBOL: +stopped+
|
||||||
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
|
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
|
||||||
{ [ dup array? ] [ add-breakpoint , \ break , ] }
|
{ [ dup array? ] [ add-breakpoint , \ break , ] }
|
||||||
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
|
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
|
||||||
{ [ t ] [ , \ break , ] }
|
[ , \ break , ]
|
||||||
} cond %
|
} cond %
|
||||||
] [ ] make
|
] [ ] make
|
||||||
] change-frame ;
|
] change-frame ;
|
||||||
|
|
|
@ -29,7 +29,7 @@ TUPLE: avl-node balance ;
|
||||||
avl-node-balance {
|
avl-node-balance {
|
||||||
{ [ dup zero? ] [ 2drop 0 0 ] }
|
{ [ dup zero? ] [ 2drop 0 0 ] }
|
||||||
{ [ over = ] [ neg 0 ] }
|
{ [ over = ] [ neg 0 ] }
|
||||||
{ [ t ] [ 0 swap ] }
|
[ 0 swap ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: double-rotate ( node -- node )
|
: double-rotate ( node -- node )
|
||||||
|
@ -89,7 +89,7 @@ M: avl set-at ( value key node -- node )
|
||||||
current-side get over avl-node-balance {
|
current-side get over avl-node-balance {
|
||||||
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
|
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
|
||||||
{ [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
|
{ [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
|
||||||
{ [ t ] [ dupd neg change-balance rebalance-delete ] }
|
[ dupd neg change-balance rebalance-delete ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: avl-replace-with-extremity ( to-replace node -- node shorter? )
|
: avl-replace-with-extremity ( to-replace node -- node shorter? )
|
||||||
|
|
|
@ -112,7 +112,7 @@ M: tree set-at ( value key tree -- )
|
||||||
[ 2drop t ] }
|
[ 2drop t ] }
|
||||||
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
|
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
|
||||||
[ drop [ node-key ] keep node-value t ] }
|
[ drop [ node-key ] keep node-value t ] }
|
||||||
{ [ t ] [ >r node-right r> find-node ] }
|
[ >r node-right r> find-node ]
|
||||||
} cond ; inline
|
} cond ; inline
|
||||||
|
|
||||||
M: tree-mixin assoc-find ( tree quot -- key value ? )
|
M: tree-mixin assoc-find ( tree quot -- key value ? )
|
||||||
|
|
|
@ -10,23 +10,13 @@ IN: unix.stat
|
||||||
|
|
||||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||||
|
|
||||||
: S_IFDIR OCT: 40000 ; ! Directory.
|
: S_IFDIR OCT: 40000 ; inline ! Directory.
|
||||||
: S_IFCHR OCT: 20000 ; ! Character device.
|
: S_IFCHR OCT: 20000 ; inline ! Character device.
|
||||||
: S_IFBLK OCT: 60000 ; ! Block device.
|
: S_IFBLK OCT: 60000 ; inline ! Block device.
|
||||||
: S_IFREG OCT: 100000 ; ! Regular file.
|
: S_IFREG OCT: 100000 ; inline ! Regular file.
|
||||||
: S_IFIFO OCT: 010000 ; ! FIFO.
|
: S_IFIFO OCT: 010000 ; inline ! FIFO.
|
||||||
: S_IFLNK OCT: 120000 ; ! Symbolic link.
|
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
|
||||||
: S_IFSOCK OCT: 140000 ; ! Socket.
|
: S_IFSOCK OCT: 140000 ; inline ! Socket.
|
||||||
|
|
||||||
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
|
|
||||||
|
|
||||||
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
|
|
||||||
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
|
|
||||||
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
|
|
||||||
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
|
|
||||||
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
|
|
||||||
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
|
|
||||||
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
! File Access Permissions
|
! File Access Permissions
|
||||||
|
|
|
@ -52,22 +52,22 @@ GENERIC: client-event ( event window -- )
|
||||||
|
|
||||||
: handle-event ( event window -- )
|
: handle-event ( event window -- )
|
||||||
over XAnyEvent-type {
|
over XAnyEvent-type {
|
||||||
{ [ dup Expose = ] [ drop expose-event ] }
|
{ \ Expose [ expose-event ] }
|
||||||
{ [ dup ConfigureNotify = ] [ drop configure-event ] }
|
{ \ ConfigureNotify [ configure-event ] }
|
||||||
{ [ dup ButtonPress = ] [ drop button-down-event$ ] }
|
{ \ ButtonPress [ button-down-event$ ] }
|
||||||
{ [ dup ButtonRelease = ] [ drop button-up-event$ ] }
|
{ \ ButtonRelease [ button-up-event$ ] }
|
||||||
{ [ dup EnterNotify = ] [ drop enter-event ] }
|
{ \ EnterNotify [ enter-event ] }
|
||||||
{ [ dup LeaveNotify = ] [ drop leave-event ] }
|
{ \ LeaveNotify [ leave-event ] }
|
||||||
{ [ dup MotionNotify = ] [ drop motion-event ] }
|
{ \ MotionNotify [ motion-event ] }
|
||||||
{ [ dup KeyPress = ] [ drop key-down-event ] }
|
{ \ KeyPress [ key-down-event ] }
|
||||||
{ [ dup KeyRelease = ] [ drop key-up-event ] }
|
{ \ KeyRelease [ key-up-event ] }
|
||||||
{ [ dup FocusIn = ] [ drop focus-in-event ] }
|
{ \ FocusIn [ focus-in-event ] }
|
||||||
{ [ dup FocusOut = ] [ drop focus-out-event ] }
|
{ \ FocusOut [ focus-out-event ] }
|
||||||
{ [ dup SelectionNotify = ] [ drop selection-notify-event ] }
|
{ \ SelectionNotify [ selection-notify-event ] }
|
||||||
{ [ dup SelectionRequest = ] [ drop selection-request-event ] }
|
{ \ SelectionRequest [ selection-request-event ] }
|
||||||
{ [ dup ClientMessage = ] [ drop client-event ] }
|
{ \ ClientMessage [ client-event ] }
|
||||||
{ [ t ] [ 3drop ] }
|
[ 3drop ]
|
||||||
} cond ;
|
} case ;
|
||||||
|
|
||||||
: configured-loc ( event -- dim )
|
: configured-loc ( event -- dim )
|
||||||
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
|
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
|
||||||
|
|
|
@ -111,7 +111,7 @@ TAG: boolean xml>item
|
||||||
dup children>string {
|
dup children>string {
|
||||||
{ [ dup "1" = ] [ 2drop t ] }
|
{ [ dup "1" = ] [ 2drop t ] }
|
||||||
{ [ "0" = ] [ drop f ] }
|
{ [ "0" = ] [ drop f ] }
|
||||||
{ [ t ] [ "Bad boolean" server-error ] }
|
[ "Bad boolean" server-error ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: unstruct-member ( tag -- )
|
: unstruct-member ( tag -- )
|
||||||
|
|
|
@ -86,7 +86,7 @@ SYMBOL: ns-stack
|
||||||
{ [ dup not ] [ 2drop ] }
|
{ [ dup not ] [ 2drop ] }
|
||||||
{ [ 2dup = ] [ 2drop next ] }
|
{ [ 2dup = ] [ 2drop next ] }
|
||||||
{ [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
|
{ [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
|
||||||
{ [ t ] [ , next (parse-char) ] }
|
[ , next (parse-char) ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: parse-char ( ch -- string )
|
: parse-char ( ch -- string )
|
||||||
|
@ -194,9 +194,9 @@ SYMBOL: ns-stack
|
||||||
{
|
{
|
||||||
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
|
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
|
||||||
{ [ CHAR: ? = ] [ next instruct ] }
|
{ [ CHAR: ? = ] [ next instruct ] }
|
||||||
{ [ t ] [
|
[
|
||||||
start-tag [ dup add-ns pop-ns <closer> ]
|
start-tag [ dup add-ns pop-ns <closer> ]
|
||||||
[ middle-tag end-tag ] if
|
[ middle-tag end-tag ] if
|
||||||
CHAR: > expect
|
CHAR: > expect
|
||||||
] }
|
]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
Loading…
Reference in New Issue