178 lines
3.9 KiB
Text
178 lines
3.9 KiB
Text
[ nextword
|
|
dup $ "" = if
|
|
[ $ '"bin" needs to be followed by a string.'
|
|
message put bail ]
|
|
dup
|
|
2 base put
|
|
$->n
|
|
base release
|
|
not if
|
|
[ drop
|
|
$ " is not a binary number."
|
|
join message put
|
|
bail ]
|
|
nip
|
|
swap dip join ] builds bin ( [ $ --> [ $ )
|
|
|
|
[ ^ not ] is zeq ( z z --> b )
|
|
|
|
[ zeq not ] is zne ( z z --> b )
|
|
|
|
[ false unrot
|
|
[ 2dup zne while
|
|
rot drop
|
|
dup 1 & unrot
|
|
1 >> dip [ 1 >> ]
|
|
again ]
|
|
2drop ] is zlt ( z z --> b )
|
|
|
|
[ swap zlt ] is zgt ( z z --> b )
|
|
|
|
[ zlt not ] is zge ( z z --> b )
|
|
|
|
[ zgt not ] is zle ( z z --> b )
|
|
|
|
[ dup 1 << & 0 zeq ] is canonical ( z --> b )
|
|
|
|
[ [] swap
|
|
[ dup 1 & rot join
|
|
swap 1 >>
|
|
dup not until ]
|
|
drop ] is bits ( z --> [ )
|
|
|
|
[ dup canonical if done
|
|
0 0 rot bits
|
|
witheach
|
|
[ |
|
|
[ table
|
|
[ 1 << 0 ]
|
|
[ 1 << 1 | bin 10 ]
|
|
[ 1 << 0 ]
|
|
[ 1 >> 1 |
|
|
bin 10 << 0 ] ]
|
|
do ]
|
|
drop again ] is canonise ( z --> z )
|
|
|
|
[ dup bin -100
|
|
& swap bin 11 & ] is 2blit ( z --> z z )
|
|
|
|
[ 2blit bit | canonise ] is zinc ( z --> z )
|
|
|
|
[ dup 0 zeq if
|
|
[ $ "Cannot zdec zero."
|
|
fail ]
|
|
1
|
|
[ 2dup & if done
|
|
1 << again ]
|
|
tuck ^
|
|
swap 1 <<
|
|
[ bin 10 >>
|
|
tuck | swap
|
|
dup 0 zeq until ]
|
|
drop ] is zdec ( z --> z )
|
|
|
|
forward is zadd ( z --> z )
|
|
|
|
[ dup 2blit
|
|
[ table
|
|
0 bin 10 bin 101 ]
|
|
unrot bin 10 >>
|
|
swap 1 <<
|
|
rot | zadd ] is zdouble ( z --> z )
|
|
|
|
[ 2dup ^ canonise
|
|
unrot &
|
|
dup 0 zeq iff
|
|
drop done
|
|
zdouble again ] resolves zadd ( z z --> z )
|
|
|
|
[ tuck take zadd swap put ] is ztally ( z s --> )
|
|
|
|
[ 0 temp put
|
|
dip dup
|
|
[ dup while
|
|
dup 1 & if
|
|
[ over temp ztally ]
|
|
dip [ tuck zadd ]
|
|
1 >> again ]
|
|
drop 2drop temp take ] is zmult ( z z --> z )
|
|
|
|
[ 2dup & ~ tuck & dip & ] is exorcise ( z z --> z z )
|
|
|
|
[ dup
|
|
[ 0 ' [ 0 0 0 ] rot 1
|
|
[ 2dup > while
|
|
1 << again ]
|
|
1 <<
|
|
[ dup while
|
|
2swap 2over & 0 !=
|
|
dip
|
|
[ dup
|
|
' [ 1 0 0 ]
|
|
= if
|
|
[ drop
|
|
' [ 0 1 1 ] ] ]
|
|
join
|
|
behead
|
|
rot 1 << | swap
|
|
2swap 1 >> again ]
|
|
2drop
|
|
witheach
|
|
[ dip [ 1 << ] | ]
|
|
dup bin 111 &
|
|
bin 100 zeq if
|
|
[ bin -1000 &
|
|
bin 11 | ] ]
|
|
2dup zeq iff drop done
|
|
nip again ] is defrock ( z --> z )
|
|
|
|
[ 2dup zlt if swap
|
|
dup 0 zeq iff drop done
|
|
[ exorcise dup while
|
|
dip defrock
|
|
exorcise dup while
|
|
dup dip zadd
|
|
zdouble
|
|
again ]
|
|
drop canonise ] is zdiff ( z z --> z )
|
|
|
|
[ dup 0 zeq if
|
|
[ $ "Z-division by zero."
|
|
fail ]
|
|
0 unrot swap
|
|
temp put
|
|
dup nested
|
|
[ dup 0 peek
|
|
tuck dip rot zadd
|
|
temp share
|
|
over zge while
|
|
swap join
|
|
again ]
|
|
drop nip
|
|
temp take
|
|
swap witheach
|
|
[ rot 1 << unrot
|
|
2dup zge iff
|
|
[ zdiff
|
|
dip [ 1 | ] ]
|
|
else drop ] ] is zdivmod ( z z --> z z )
|
|
|
|
[ zdivmod drop ] is zdiv ( z z --> z )
|
|
|
|
[ zdivmod nip ] is zmod ( z z --> z )
|
|
|
|
[ [ dup while
|
|
tuck zmod again ]
|
|
drop ] is zgcd ( z z --> z )
|
|
|
|
[ 2dup and iff
|
|
[ 2dup zgcd
|
|
zdiv zmult ]
|
|
else and ] is zlcm ( z z --> z )
|
|
|
|
10 times
|
|
[ 10 15 ** random
|
|
10 15 ** random
|
|
2dup lcm echo cr
|
|
n->z dip n->z
|
|
zlcm z->n echo cr cr ]
|