A toy package designed to showcase and serve as a reference/tutorial for S7 development. To be used in conjunction with the S7 package webs
Basic implementation completed.
+123
-23
+123
-23
R/big_num.R
+123
-23
R/big_num.R
···
67
67
# TODO: validation might be broken?
68
68
if (!node_or_na(self@head)) {
69
69
"@head must be a `node` object or `NA`."
70
-
} else if (!node_or_na(self@head)) {
70
+
} else if (!node_or_na(self@tail)) {
71
71
"@tail must be a `node` object or `NA`."
72
72
}
73
73
}, constructor = function(num = NULL) {
···
92
92
}
93
93
)
94
94
95
+
#' Makes a BigNum
96
+
#'
97
+
#' @param num A character vector representing a number.
98
+
#'
99
+
#' @return A big_num S7 object.
100
+
#' @export
101
+
#'
102
+
#' @examples
95
103
big_num <- new_class("big_num",
96
104
package = "BigNum",
97
105
properties = list(
98
106
ll = new_property(linked_list, getter = function(self) self@ll)
99
107
),
100
108
constructor = function(num = "") {
101
-
S7::new_object(S7::S7_object(), ll = linked_list(num))
109
+
S7::new_object(S7::S7_object(), ll = linked_list(format(num, trim = TRUE, scientific = FALSE)))
102
110
}
103
111
)
104
112
105
113
is.na <- new_external_generic("base", "is.na", "x")
106
114
method(is.na, node) <- function(x) !S7_inherits(x, node)
107
115
108
-
append <- new_generic("append", "x", function(x, ll, ...) S7_dispatch())
109
-
method(append, node) <- function(x, ll) {
116
+
is_even <- new_generic("is_even", c("x"))
117
+
method(is_even, big_num) <- function(x) x@ll@head@VALUE %% 2 == 0
118
+
119
+
append <- new_generic("append", c("x", "ll"))
120
+
method(append, list(node, linked_list)) <- function(x, ll) {
110
121
suppressWarnings(
111
122
if (is.na(ll@head)) {
112
123
ll@head <- x
···
125
136
126
137
invisible(ll)
127
138
}
128
-
method(append, class_numeric) <- function(x, ll) {
139
+
method(append, list(class_numeric, linked_list)) <- function(x, ll) {
129
140
stopifnot(x < 10 && x >= 0)
130
141
append(node(x), ll)
142
+
}
143
+
method(append, list(class_numeric | node, big_num)) <- function(x, ll) {
144
+
append(x, ll@ll)
131
145
}
132
146
133
-
append_to_start <- new_generic("append_to_start", "x", function(x, ll, ...) S7_dispatch())
134
-
method(append_to_start, node) <- function(x, ll) {
147
+
append_to_start <- new_generic("append_to_start", c("x", "ll"))
148
+
method(append_to_start, list(node, linked_list)) <- function(x, ll) {
135
149
suppressWarnings(
136
150
if (is.na(ll@head)) {
137
151
ll@head <- x
···
146
160
147
161
invisible(ll)
148
162
}
149
-
method(append_to_start, class_numeric) <- function(x, ll) {
163
+
method(append_to_start, list(class_numeric, linked_list)) <- function(x, ll) {
150
164
stopifnot(x < 10 && x >= 0)
151
165
append_to_start(node(x), ll)
166
+
}
167
+
method(append_to_start, list(class_numeric | node, big_num)) <- function(x, ll) {
168
+
append_to_start(x, ll@ll)
152
169
}
153
170
154
171
print <- new_external_generic("base", "print", "x")
···
162
179
163
180
invisible(x)
164
181
}
165
-
166
182
method(print, big_num) <- function(x) {
167
183
len <- x@ll@length
168
184
···
171
187
return(invisible(x))
172
188
}
173
189
190
+
# TODO: remove leading 0s?
174
191
stack <- character(len)
175
192
current <- x@ll@head
176
193
···
186
203
}
187
204
188
205
`+` <- new_external_generic("base", "+", c("e1", "e2"))
189
-
# TODO: write this
206
+
add_helper <- function(node1, node2, carry, sum) {
207
+
digit <- node1@VALUE + node2@VALUE + carry
208
+
carry <- digit %/% 10
209
+
digit <- digit %% 10
210
+
append(digit, sum)
211
+
212
+
carry
213
+
}
190
214
method(`+`, list(big_num, big_num)) <- function(e1, e2) {
191
215
sum <- big_num()
192
-
}
216
+
node1 <- e1@ll@head
217
+
node2 <- e2@ll@head
218
+
carry <- 0
193
219
220
+
while (!is.na(node1) && !is.na(node2)) {
221
+
carry <- add_helper(node1, node2, carry, sum)
222
+
node1 <- node1@nxt
223
+
node2 <- node2@nxt
224
+
}
225
+
while (!is.na(node1)) {
226
+
carry <- add_helper(node1, node(0), carry, sum)
227
+
node1 <- node1@nxt
228
+
}
229
+
while (!is.na(node2)) {
230
+
carry <- add_helper(node2, node(0), carry, sum)
231
+
node2 <- node2@nxt
232
+
}
233
+
if (carry > 0) {
234
+
append(carry, sum)
235
+
}
236
+
237
+
sum
238
+
}
194
239
method(`+`, list(big_num, class_numeric)) <- function(e1, e2) {
195
240
e1 + big_num(e2)
196
241
}
197
-
198
242
method(`+`, list(class_numeric, big_num)) <- function(e1, e2) {
199
243
big_num(e1) + e2
200
244
}
201
245
202
-
# x <- big_num("")
203
-
# x@ll
204
-
# len <- x@ll@length
205
-
# stack <- character(len)
206
-
# current <- x@ll@head
246
+
`*` <- new_external_generic("base", "*", c("e1", "e2"))
247
+
method(`*`, list(big_num, big_num)) <- function(e1, e2) {
248
+
product <- big_num(0)
249
+
node2 <- e2@ll@head
250
+
shift2 <- 0
251
+
while (!is.na(node2)) {
252
+
node1 <- e1@ll@head
253
+
shift1 <- 0
254
+
while (!is.na(node1)) {
255
+
temp <- big_num(node1@VALUE * node2@VALUE)
256
+
replicate(shift1 + shift2, append_to_start(0, temp))
257
+
product <- product + temp
258
+
node1 <- node1@nxt
259
+
shift1 <- shift1 + 1
260
+
}
261
+
node2 <- node2@nxt
262
+
shift2 <- shift2 + 1
263
+
}
207
264
208
-
# for (i in len:1) {
209
-
# stack[i] <- current@VALUE
210
-
# current <- current@nxt
211
-
# }
265
+
product
266
+
}
267
+
method(`*`, list(big_num, class_numeric)) <- function(e1, e2) {
268
+
e1 * big_num(e2)
269
+
}
270
+
method(`*`, list(class_numeric, big_num)) <- function(e1, e2) {
271
+
big_num(e1) * e2
272
+
}
273
+
274
+
`^` <- new_external_generic("base", "^", c("e1", "e2"))
275
+
method(`^`, list(big_num, class_numeric)) <- function(e1, e2) {
276
+
if (e2 == 0) {
277
+
return(big_num(1))
278
+
} else if (e2 == 1) {
279
+
return(e1)
280
+
} else if (e2 == 2) {
281
+
return(e1 * e1)
282
+
} else {
283
+
if (e2 %% 2 == 1) {
284
+
return((e1^2)^(e2 %/% 2))
285
+
} else {
286
+
return((e1^2)^(e2 %/% 2) * e1)
287
+
}
288
+
}
289
+
}
212
290
213
-
# string <- paste0(stack, collapse = "")
214
-
# cat(string)
291
+
`==` <- new_external_generic("base", "==", c("e1", "e2"))
292
+
method(`==`, list(big_num, big_num)) <- function(e1, e2) {
293
+
len <- e1@ll@length
294
+
if (len != e2@ll@length) {
295
+
return(FALSE)
296
+
}
297
+
node1 <- e1@ll@head
298
+
node2 <- e2@ll@head
299
+
for (i in len:1) {
300
+
if (node1@VALUE != node2@VALUE) {
301
+
return(FALSE)
302
+
}
303
+
node1 <- node1@nxt
304
+
node2 <- node2@nxt
305
+
}
306
+
TRUE
307
+
}
308
+
method(`==`, list(big_num, class_numeric)) <- function(e1, e2) {
309
+
e1 == big_num(e2)
310
+
}
311
+
method(`==`, list(class_numeric, big_num)) <- function(e1, e2) {
312
+
big_num(e1) == e2
313
+
}
314
+