-
Notifications
You must be signed in to change notification settings - Fork 1
/
forthress-words.frt
123 lines (103 loc) · 1.58 KB
/
forthress-words.frt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
( a - b: {1 if even, 0 otherwise} )
: even
2 % not dup
if
." 1" cr
else
." 0" cr
then
;
( a - b: {lowest b: b*b >= a} )
: sqrt
dup 2 / 1 +
1
for
dup dup
r@ dup * swap
< not
swap
r@ 1 + dup * swap
< not
<
if
r@ 1 +
then
endfor
swap drop
;
( a b - a b a b )
: dup2
( a b - b a - b a a - a a b - a a b b - a b b a - a b a b)
swap
dup
rot
dup
rot
swap
;
( a - b: {1 if prime, 0 otherwise} )
: prime
dup 1 = if exit then
dup 2 = if exit then
dup sqrt
1
repeat
1 +
dup2
<
if
drop drop drop
1 exit
then
rot dup2 swap
% not
if
drop drop drop
0 exit
then
rot rot
0
until
;
( Shows 2 stack elements. Does not pop them. )
: .!
dup2 . cr . cr
;
( num - addr )
: prime-store
prime
1 allot
dup rot swap
c!
;
( addr1 addr2 - res_addr )
: concat
dup2
swap
( a1 a2 - a1 a2 l1 l2 - a1 a2 l3 - a1 a2 a3 )
dup2 count swap count swap
+ 1 +
heap-alloc
( a1 a2 a3 - a2 a3 a3 a1 [l1] - a3' a3' a2 [l1] - a3' [l1] - a3 )
dup rot dup count >r
string-copy
r@ + dup rot
string-copy
r> -
rot heap-free
swap heap-free
;
( a - b )
: collatz-conj
dup . cr
repeat
dup 2 %
if
3 * 1 +
else
2 /
then
dup . cr
dup 1 =
until
;