r/core.r

   1 ..core.. <- TRUE
   2
   3 if(!exists("..types..")) source("types.r")
   4 if(!exists("..printer..")) source("printer.r")
   5
   6
   7 # String functions
   8
   9 pr_str <- function(...)
  10     .pr_list(list(...), print_readably=TRUE, join=" ")
  11
  12 str <- function(...)
  13     .pr_list(list(...), print_readably=FALSE, join="")
  14
  15 prn <- function(...) {
  16     cat(.pr_list(list(...), print_readably=TRUE, join=" "))
  17     cat("\n")
  18     nil
  19 }
  20
  21 println <- function(...) {
  22     cat(.pr_list(list(...), print_readably=FALSE, join=" "))
  23     cat("\n")
  24     nil
  25 }
  26
  27 do_readline <- function(prompt) {
  28     l <- readline(prompt)
  29     if (is.null(l)) nil else l
  30 }
  31
  32 # Hash Map functions
  33 do_get <- function(hm,k) {
  34     if (class(hm) == "nil") return(nil)
  35     v <- hm[[k]]
  36     if (is.null(v)) nil else v
  37 }
  38 contains_q <-function(hm,k) {
  39     if (class(hm) == "nil") return(FALSE)
  40     if (is.null(hm[[k]])) FALSE else TRUE
  41 }
  42
  43 # Sequence functions
  44 cons <- function(a,b) {
  45     new_lst <- append(list(a), b)
  46     new.listl(new_lst)
  47 }
  48
  49 nth <- function(a,b) {
  50     if (b < length(a))
  51         a[[b+1]]
  52     else
  53         throw("nth: index out of range")
  54 }
  55
  56 do_concat <- function(...) {
  57     new_lst <- list()
  58     for(l in list(...)) {
  59         new_lst <- append(new_lst, l)
  60     }
  61     new.listl(new_lst)
  62 }
  63
  64 do_apply <- function(f, ...) {
  65     p <- list(...)
  66     args <- list()
  67     if (length(p) > 1) {
  68         for(l in slice(p, 1, length(p)-1)) {
  69             args[[length(args)+1]] <- l
  70         }
  71     }
  72     args <- append(args, p[[length(p)]])
  73     fapply(f, args)
  74 }
  75
  76 map <- function(f, seq) {
  77     new.listl(lapply(seq, function(el) fapply(f, list(el))))
  78 }
  79
  80 conj <- function(obj, ...) {
  81     p <- list(...)
  82     new_obj <- .clone(obj)
  83     if (.list_q(obj)) {
  84         if (length(p) > 0) {
  85             for(l in p) new_obj <- append(list(l), new_obj)
  86         }
  87         new.listl(new_obj)
  88     } else if (.vector_q(obj)) {
  89         if (length(p) > 0) {
  90             for(l in p) new_obj <- append(new_obj, list(l))
  91         }
  92         new.vectorl(new_obj)
  93     } else {
  94         throw("conj called on non-sequence")
  95     }
  96 }
  97
  98 do_seq <- function(obj) {
  99     if (.list_q(obj)) {
 100         if (length(obj) == 0) nil else obj
 101     } else if (.vector_q(obj)) {
 102         if (length(obj) == 0) nil else new.listl(.clone(obj))
 103     } else if (.string_q(obj)) {
 104         if (nchar(obj) == 0) nil else new.listl(strsplit(obj, "")[[1]])
 105     } else if (class(obj) == "nil") {
 106         nil
 107     } else {
 108         throw("seq: called on non-sequence")
 109     }
 110 }
 111
 112
 113 # Metadata functions
 114 with_meta <- function(obj, m) {
 115     new_obj <- .clone(obj)
 116     attr(new_obj, "meta") <- m
 117     new_obj
 118 }
 119
 120 meta <- function(obj) {
 121     m <- attr(obj, "meta")
 122     if (is.null(m)) nil else m
 123 }
 124
 125 # Atom functions
 126 deref <- function(atm) atm$val
 127 reset_bang <- function (atm, val) { atm$val <- val; val }
 128 swap_bang <- function (atm, f, ...) {
 129     p <- list(...)
 130     args <- list(atm$val)
 131     if (length(p) > 0) {
 132         for(l in p) args[[length(args)+1]] <- l
 133     }
 134     atm$val <- fapply(f, args)
 135 }
 136
 137 core_ns <- list(
 138     "="=function(a,b) .equal_q(a,b),
 139     "throw"=function(err) throw(err),
 140     "nil?"=.nil_q,
 141     "true?"=.true_q,
 142     "false?"=.false_q,
 143     "string?"=.string_q,
 144     "symbol"=new.symbol,
 145     "symbol?"=.symbol_q,
 146     "keyword"=new.keyword,
 147     "keyword?"=.keyword_q,
 148     "number?"=.number_q,
 149     "fn?"=.fn_q,
 150     "macro?"=.macro_q,
 151
 152     "pr-str"=pr_str,
 153     "str"=str,
 154     "prn"=prn,
 155     "println"=println,
 156     "readline"=do_readline,
 157     "read-string"=function(str) read_str(str),
 158     "slurp"=function(path) readChar(path, file.info(path)$size),
 159     "<"=function(a,b) a<b,
 160     "<="=function(a,b) a<=b,
 161     ">"=function(a,b) a>b,
 162     ">="=function(a,b) a>=b,
 163     "+"=function(a,b) a+b,
 164     "-"=function(a,b) a-b,
 165     "*"=function(a,b) a*b,
 166     "/"=function(a,b) a/b,
 167     "time-ms"=function() round(as.numeric(Sys.time())*1000),
 168
 169     "list"=new.list,
 170     "list?"=function(a) .list_q(a),
 171     "vector"=new.vector,
 172     "vector?"=function(a) .vector_q(a),
 173     "hash-map"=new.hash_map,
 174     "map?"=function(a) .hash_map_q(a),
 175     "assoc"=function(hm,...) .assoc(hm,list(...)),
 176     "dissoc"=function(hm,...) .dissoc(hm,list(...)),
 177     "get"=do_get,
 178     "contains?"=contains_q,
 179     "keys"=function(hm) new.listl(ls(hm)),
 180     "vals"=function(hm) new.listl(lapply(ls(hm), function(x) hm[[x]])),
 181
 182     "sequential?"=.sequential_q,
 183     "cons"=cons,
 184     "concat"=do_concat,
 185     "nth"=nth,
 186     "first"=function(a) if (.nil_q(a) || length(a) < 1) nil else a[[1]],
 187     "rest"=function(a) if (.nil_q(a)) new.list() else new.listl(slice(a,2)),
 188     "empty?"=function(a) .sequential_q(a) && length(a) == 0,
 189     "count"=function(a) if (.nil_q(a)) 0 else length(a),
 190     "apply"=do_apply,
 191     "map"=map,
 192
 193     "conj"=conj,
 194     "seq"=do_seq,
 195
 196     "with-meta"=with_meta,
 197     "meta"=meta,
 198     "atom"=new.atom,
 199     "atom?"=.atom_q,
 200     "deref"=deref,
 201     "reset!"=reset_bang,
 202     "swap!"=swap_bang
 203 )