nydp 0.4.0 → 0.4.6

data/lib/lisp/core-035-flow-control.nydp

@@ -40,21 +40,30 @@
        (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
          ,@body))))
 
-(mac curry (func . args1)
-  ; return a new function which is the original function with
-  ; the given args1 already applied
-  ; arguments to the new function are whatever arguments remain
-  ; for the old function
-  `(fn args (apply ,func ,@args1 args)))
+;; return a new function which is the original function with
+;; the given args1 already applied
+;; arguments to the new function are whatever arguments remain
+;; for the old function
+;; Could be (mac curry things `(fn args (apply ,@things args))) but less readable
+(mac curry (f . args0)
+  `(fn args
+       (apply ,f ,@args0 args)))
+
+;; like curry, but the returned function takes only a single arg (assumes all
+;; args but one are provided here)
+;; Could be (mac curry1 things `(fn (arg) (,@things arg))) but less readable
+(mac curry1 (f . args)
+  `(fn (arg)
+       (,f ,@args arg)))
 
 (mac cache-get (hsh key val)
   ; if ,key is already in ,hsh - return the associated value.
   ; if ,key is not already in ,hsh - evaluate ,val, store the result
   ; under ,key in ,hsh, and return it
   (w/uniq (h k v)
-    `(with (,h ,hsh ,k ,key)
-           (let ,v (hash-get ,h ,k)
-             (or ,v (returnlet ,v ,val (hash-set ,h ,k ,v)))))))
+          `(with (,h ,hsh ,k ,key)
+                 (let ,v (hash-get ,h ,k)
+                   (or ,v (returnlet ,v ,val (hash-set ,h ,k ,v)))))))
 
 (mac defmemo (name args . body)
   ; same as 'def, but caches the result, keyed on args, so for a given set of args the result

data/lib/lisp/core-037-list-utils.nydp

@@ -6,35 +6,57 @@
       (cons (map car args)
             (apply zip (map cdr args)))))
 
+; invokes 'f for each element of 'things, first element processed first
+; ( "l" in "eachl" = "leftmost first" )
+(def eachl (f things)
+     (when things
+       (f (car things))
+       (eachl f (cdr things))))
+
+;; if things is a pair,
+;;   if (cdr things) is nil, return (car things)
+;;   else recurse on (cdr things)
+;; else return things
+(def list/last (things)
+  (if (pair? things)
+      (aif (cdr things)
+           (list/last it)
+           (car things))
+      things))
+
+; invokes 'f for each element of 'things, last element processed first
+; ( "r" in "eachr" = "rightmost first" )
 (def eachr (f things)
      (when things
        (eachr f (cdr things))
        (f (car things))))
 
-(mac push (x things)
-  ; assign (cons x things) to things
-  `(= ,things (cons ,x ,things)))
+; assign (cons x things) to things
+(mac push (x things) `(= ,things (cons ,x ,things)))
 
-(def flatten (things)
-  ; flatten the given list, recursively
+; flatten the given list, transforming each leaf-item, recursively
+(def flatmap (f things)
      (let acc nil
           (rfnwith flattenize (x things)
                    (if (pair? x)
                        (eachr flattenize x)
-                       (push x acc)))
+                       x
+                       (push (f x) acc)))
           acc))
 
+; flatten the given list, recursively
+(def flatten (things) (flatmap x1 things))
+
+; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
+; a 'key, returns the list (kx vx) from 'al where kx is equal to 'key
+; #attribution: inspiration from arc.arc
 (def assoc (key al)
-  ; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
-  ; a 'key, returns the list (kx vx) from 'al where kx is equal to 'key
-  ; #attribution: inspiration from arc.arc
   (if (pair? al)
       (if (caris key (car al))
           (car al)
           (assoc key (cdr al)))))
 
-(def alref (key al)
-  ; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
-  ; a 'key, returns vx from 'al where kx is equal to 'key
-  ; #attribution: lifted almost directly from arc.arc
-  (cadr (assoc key al)))
+; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
+; a 'key, returns vx from 'al where kx is equal to 'key
+; #attribution: lifted almost directly from arc.arc
+(def alref (key al) (cadr (assoc key al)))

data/lib/lisp/core-039-module.nydp

@@ -0,0 +1,24 @@
+;; creates a private namespace for support functions for one or more explicitly exported/public functions
+;;
+;; (module foo
+;;   (def h ...)
+;;   (def u ...)
+;;   (export bar (x y) (h u x y)))
+;;
+;; results in 'foo/bar being universally available, but 'h and 'u are visible only within the module and override
+;; any other 'h or 'u defined elsewhere, in the scope of the module.
+(mac module (module-name . forms)
+  (let private-names nil
+    (let module-forms
+         { def        (fn (name args . body)
+                          (push nil  private-names)
+                          (push name private-names)
+                          `(assign ,name (fn ,args ,@body)))
+           export-def macs.def
+           export     (fn (name args . body)
+                          `(export-def
+                            ,(sym (+ (to-string module-name) "/" (to-string name)))
+                            ,args
+                            ,@body)) }
+      (let module-body (pre-compile-each module-forms forms)
+        `(with (,@private-names) ,@module-body)))))

data/lib/lisp/core-040-utils.nydp

@@ -11,22 +11,20 @@
 (def num?    (arg) (comment "true if arg is a number") (isa 'number arg))
 (def string? (arg) (comment "true if arg is a string") (isa 'string arg))
 
-(mac just (expr)
-  ; this is useful sometimes when 'expr can't stand on its own due to lexical ambiguity, most often in string interpolations
-  ; for example, in "hello ~person, how are you", the parser will try to interpolate the symbol "person," rather than the
-  ; expected "person". In this case, use "hello ~(just person), how are you"
-  expr)
+;; this is useful sometimes when 'expr can't stand on its own due to lexical ambiguity, most often in string interpolations
+;; for example, in "hello ~person, how are you", the parser will try to interpolate the symbol "person," rather than the
+;; expected "person". In this case, use "hello ~(just person), how are you"
+(mac just (expr) expr)
 
 (def quotify (arg) `(quote ,arg))
 
-(defmemo k (arg)
-  ; return a function that always returns 'arg, similar to K in SKI calculus
-  (fn nil arg))
+;; return a function that always returns 'arg, similar to K in SKI calculus
+(defmemo k (arg) (fn nil arg))
 
+;; return the length of 'things where 'things may be nil, a string, list or hash
+;; length of nil is zero, length of hash is number of keys, length of string
+;; is number of characters, length of list is number of direct items - no recursive counting
 (def len (things)
-  ; return the length of 'things where 'things may be nil, a string, list or hash
-  ; length of nil is zero, length of hash is number of keys, length of string
-  ; is number of characters, length of list is number of direct items - no recursive counting
   (chapter list-manipulation)
   (chapter string-manipulation)
   (chapter hash-manipulation)
@@ -38,25 +36,34 @@
 
 (assign dynamics (hash))
 
-(mac dynamic (name)
-  ; creates a dynamic variable.
-  (hash-set dynamics name t)
-  (let with-mac-name (sym "w/~name")
+;; creates a dynamic variable.
+(mac dynamic (name initial)
+  (let with-mac-name (sym:+ "w/" name)
     (w/uniq prev
       `(do
-        (mac ,with-mac-name (new-value . body)
-             (w/uniq result
-                     `(let ,',prev (hash-get (thread-locals) ',',name)
-                           (hash-set (thread-locals) ',',name ,new-value)
-                           (let ,result (do ,@body)
-                             (hash-set (thread-locals) ',',name ,',prev)
-                             ,result))))
-           (def ,name () (hash-get (thread-locals) ',name))))))
+         (hash-set dynamics ',name t)
+         (mac ,with-mac-name (new-value . body)
+           (w/uniq result
+                   `(let ,',prev (hash-get (thread-locals) ',',name)
+                      (hash-set (thread-locals) ',',name ,new-value)
+                      (returning (do ,@body)
+                        (hash-set (thread-locals) ',',name ,',prev)))))
+         ,(if initial `(hash-set (thread-locals) ',name ,initial))
+         (def ,name () (hash-get (thread-locals) ',name))))))
+
+
+;; overrides 'privately defined earlier in documentation manager
+(dynamic privately)
+
+;; suppress documentation of anything defined in 'body
+(mac in-private body
+  `(w/privately t ,@body))
 
 (mac mapx (things x expr)
   ; a macro wrapper for 'map
   ; 'things is a list, 'x is the name of a variable, and 'expr
   ; is evaluated and collected for each 'x in 'things
+  ; usage: (mapx items v (to-string v)) equivalent to (map to-string items)
   (chapter list-manipulation)
   `(map (fun (,x) ,expr) ,things))
 
@@ -83,3 +90,14 @@
   (chapter string-manipulation)
   (chapter hash-manipulation)
   (!empty? thing))
+
+;; returns the first non-empty item in 'args
+;; mac equivalent of (detect present? args)
+(mac dp args
+  (if args
+      (w/uniq nearg
+        `(let ,nearg ,(car args)
+           (if (empty? ,nearg)
+               (dp ,@(cdr args))
+               ,nearg)))
+      nil))

data/lib/lisp/core-041-string-utils.nydp

@@ -1,7 +1,8 @@
 (chapter-start 'string-manipulation "utilities for manipulating strings")
 
+; return a new string with leading and trailing whitespace removed
 (def string-strip (txt)
-  (string-replace "(^\\s+|\\s+$)" "" txt))
+  (string-replace "(\\A\\s+|\\s+\\z)" "" txt))
 
 (def joinstr (txt . things)
   ; flatten 'things into a single list (ie unnest lists)
@@ -15,14 +16,41 @@
            (flatten (map (fn (x) (list txt x))
                          (cdr joinables))))))
 
-(def j items
-  ; delegate to 'joinstr with an empty join string
-  ; shortcut for (joinstr ""  items)
-  (joinstr "" items))
+; stringify join all the things and join them with no separator, like (joinstr "" things)
+(def j things
+  (apply + (flatmap to-string things)))
 
+; string-interpolation syntax emits this form. Default implementation
+; is to delegate to 'j , but containing forms may use macros that
+; override this in order to provide specific interpolation behaviour
+; (for example, formatting numbers or stripping HTML tags)
 (def string-pieces pieces
-  ; string-interpolation syntax emits this form. Default implementation
-  ; is to delegate to 'j , but containing forms may use macros that
-  ; override this in order to provide specific interpolation behaviour
-  ; (for example, formatting numbers or stripping HTML tags)
   (j pieces))
+
+; return the first 'length chars of string 'str
+(def string-truncate (str length)
+  (string-replace "(.{~|length|}).*" "\\1" str))
+
+;; returns a function with args 'args whose body is 'str. 'str should be a string,
+;; 'args should correspond to interpolations within 'str
+;;
+;; example: (string-eval-fn "hello \~u.firstname" 'u)
+;; returns (fn (u) (string-pieces "hello " u.firstname))
+(defmemo string-eval-fn (str args)
+  (eval `(fn ,args
+             ,(parse-in-string str))))
+
+;; assigns 'args respectively to 'arg-names and evals 'str in that context.
+;; Assumes 'str contains interpolations which reference 'arg-names.
+;; Useful for evaluating user-supplied strings ; dangerous for the same reason.
+;;
+;; example: (string/eval-with-args "\~x + \~y is \~(+ x y)" '(x y) 2 3)
+;; returns "2 + 3 is 5"
+;;
+(def string/eval-with-args (str arg-names . args)
+  (on-err
+   (error (j "error evaluating "  (inspect str)
+             "\nwith arg names "  (inspect arg-names)
+             "\nand args "        (inspect args)))
+   (apply (string-eval-fn str arg-names)
+          args)))

data/lib/lisp/core-042-date-utils.nydp

@@ -1,5 +1,25 @@
 (chapter-start 'date-time "utilities for retrieving and manipulating dates and times")
 
+;; return a date for the current day
 (def today ()
-  ; return a date for the current day
   (date))
+
+;; return a Time object representing the time 's seconds ago
+(def seconds-ago (s)
+  (- (time) s))
+
+(def anniversary/previous (anchor anniv)
+  (let d (date anchor.year
+               anniv.month
+               anniv.day)
+    (if (< d anchor)
+        d
+        d.last-year)))
+
+(def anniversary/next (anchor anniv)
+  (let d (date anchor.year
+               anniv.month
+               anniv.day)
+    (if (> d anchor)
+        d
+        d.next-year)))

data/lib/lisp/core-043-list-utils.nydp

@@ -23,76 +23,71 @@
              (intersperse inbetween (cdr things)))
       things))
 
+;; expects 'things a list of lists, joins the lists
+;; returns (a b X c d X e f)
+;; placing 'inbetween in between each list.
+;; For example (intersperse-splicing 'X '((a b) (c d) (e f)))
 (def intersperse-splicing (inbetween things)
-  ; expects 'things a list of lists, joins the lists
-  ; placing 'inbetween in between each list.
-  ; For example (intersperse-splicing 'X '((a b) (c d) (e f)))
-  ; returns (a b X c d X e f)
   (apply joinlists (intersperse (list inbetween) things)))
 
-(def collect (f things)
-  ; if 'things is a list, return all the items in the list for which 'f returns non-nil
-  ; otherwise, return 'things if (f things) is non-nil
-  ; otherwise, nil
-  ; note that this preserves improper lists and may return only the lastcdr if all else fails...
-  (rfnwith collector (items things)
-           (if (no items)
-               nil
-               (pair? items)
-               (if (f (car items))
-                   (cons (car items)
-                         (collector (cdr items)))
-                   (collector (cdr items)))
-               (f items)
-               items)))
+;; if 'things is a list, return all the items in the list for which 'f returns non-nil
+;; otherwise, return 'things if (f things) is non-nil
+;; otherwise, nil
+;; note that this preserves improper lists and may return only the lastcdr if all else fails...
+(def collect (f items)
+  (if (pair? items)
+      (if (f (car items))
+          (cons (car items)
+                (collect f (cdr items)))
+          (collect f (cdr items)))
+      items
+      (if (f items)
+          items)))
 
 (assign select collect)
 
-(def compact (things)
-  ; return a new list containing only non-nil items from the given list
-  (collect present? things))
+;; return a new list containing only 'present? items from the given list
+(def compact (things) (collect present? things))
 
+;; return the sum of all non-nil values (consider nil as zero)
 (def +nz args
-  ; return the sum of all non-nil values (consider nil as zero)
   (apply + (compact args)))
 
+;; return all the items in 'things for which 'f returns nil
 (def reject (f things)
-  ; return all the items in 'things for which 'f returns nil
   (collect !f things))
 
+;; returns the n-th item in the list 'things
 (def nth (n things)
-  ; returns the n-th item in the list 'things
   (if (eq? n 0)
       (car things)
       (nth (- n 1) (cdr things))))
 
+;; repeatedly assigns an element of 'things to 'var,
+;; and executes 'body each time
 (mac each (var things . body)
-  ; repeatedly assigns an element of 'things to 'var,
-  ; and executes 'body each time
   (w/uniq (xs c)
-          `((rfn ,c (,xs)
-                (if (pair? ,xs)
-                    (do (let ,var (car ,xs) ,@body)
-                        (,c (cdr ,xs)))))
-           ,things)))
+          `(rfnwith ,c (,xs ,things)
+               (if (pair? ,xs)
+                   (do (let ,var (car ,xs) ,@body)
+                       (,c (cdr ,xs)))))))
 
 (def reduce (f things)
-  ((rfn rd (acc list)
-        (if (pair? list)
-            (rd (f acc (car list))
-                (cdr list))
-            acc))
-   (car things) (cdr things)))
-
+  (rfnwith rd (acc (car things) list (cdr things))
+           (if (pair? list)
+               (rd (f acc (car list))
+                   (cdr list))
+               acc)))
+
+;; t if this is a proper list (last cdr is nil)
+;; nil otherwise (last cdr is neither cons nor nil)
 (def proper? (list)
-  ; t if this is a proper list (last cdr is nil)
-  ; nil otherwise (last cdr is neither cons nor nil)
   (or (no list)
       (and (pair? list)
            (proper? (cdr list)))))
 
+;; returns the first 'n items in the list 'things
 (def firstn (n things)
-  ; returns the first 'n items in the list 'things
   (if (eq? n 0)   nil
       things      (cons (car things)
                         (firstn (- n 1)
@@ -140,34 +135,39 @@
       (detect (curry eq? f)
               things)))
 
+;; split things into a list of lists each n long
 (def tuples (n things)
-  ;; split things into a list of lists each n long
   (rfnwith _ (list things)
            (if (no list)
                nil
                (cons (firstn n list) (_ (nthcdr n list))))))
 
-(def range (start stop)
-  ; return a list containing the range
-  ; of elements starting with 'start, up
-  ; to but not including 'stop
-  (if (< start stop)
-      (cons start
-            (range (+ start 1)
-                   stop))))
-
-(def best (f things)
-  (if (no things)
-      nil
-      (let winner (car things)
-        (each thing (cdr things)
-              (if (f thing winner)
-                  (= winner thing)))
-        winner)))
+;; iterates through 'things pairwise (a,b then b,c then c,d etc), returns whichever is preferred by 'better-p
+;; example (best > '(3 1 4 1 5 9 2)) returns 9
+;; "better-p" -> takes two args a and b, return t if a is "better" than b, nil otherwise
+(def best (better-p things)
+  (reduce (fn (a b)
+              (if (better-p a b) a b))
+          things))
 
 (def min things (best < things))
 (def max things (best > things))
 
+;; returns a function taking two args a and b, that compares attributes of two objects
+;; 'map-f takes one arg a returning a1
+;; 'compare-p takes two args a1 and b1, returns t if a1 is "better" than b1
+;;
+;; useful in conjunction with 'best : (best (map-compare-f > &size) (list { size 1 } { size 7 } { size 3 })) returns { size 7 }
+(def map-compare-f (compare-p map-f)
+  (fn (a b) (compare-p (map-f a) (map-f b))))
+
+;; iterate over 'things, calling 'on-atom for each non-list element, and calling
+;; 'on-list for each list element.
+;; 'on-atom takes one parameter, the element in question;
+;; 'on-list takes two parameters: a function to call for recursing, and the list in question.
+;; 'on-list should be something like (fn (rec xs) (foo xs) (map rec xs)) to construct a new list,
+;; or (fn (rec xs) (foo xs) (eachl rec xs)) to iterate without constructing a new list
+;; see 'list-gsub for an example of constructing a new list using this.
 (def map-recurse (on-atom on-list things)
   ((afn (xs)
     (if (pair? xs)
@@ -176,8 +176,20 @@
         (on-atom xs)))
    things))
 
+;; like map-recurse, but doesn't depend on caller to initiate recursion
+;; 'on-atom and 'on-list are functions each taking one parameter
+;; return value is last returned item from on-atom or on-list
+(def list/traverse (on-atom on-list things)
+  (map-recurse
+   (fn (s)
+       (on-atom s))
+   (fn (rec xs)
+       (on-list xs)
+       (eachl rec xs))
+   things))
+
+;; recursively replaces 'old with 'new inside 'list
 (def list-gsub (list old new)
-  ; recursively replaces 'old with 'new inside 'list
   (map-recurse (fn (s) (if (eq? s old) new s))
                (fn (m things)
                    (if (eq? things old)
@@ -186,8 +198,8 @@
                list))
 
 (def all? (f things)
-  ; if 'things is a list, true when all items are non-nil
-  ; if 'things is an atom, true when non-nil
+  ; if 'things is a list, true when f(thing) is non-nil for each thing in things
+  ; if 'things is an atom, true when f(things) is non-nil
   (if (pair? things)
       (and (f:car things)
            (or (no:cdr things)
@@ -195,8 +207,8 @@
       (f things)))
 
 (def any? (f things)
-  ; if 'things is a list, true when at least one item is non-nil
-  ; if 'things is an atom, true when non-nil
+  ; if 'things is a list, true when f(thing) is non-nil for at least one thing in things
+  ; if 'things is an atom, true when f(thing) is non-nil
   (if (pair? things)
       (or (f:car things)
           (and (cdr things)
@@ -204,8 +216,8 @@
       (f things)))
 
 (def none? (f things)
-  ; if 'things is a list, true when all items are nil
-  ; if 'things is an atom, true when nil
+  ; if 'things is a list, true when f(thing) is nil for each thing in things
+  ; if 'things is an atom, true when f(things) is nil
   (if (pair? things)
       (and (no:f:car things)
            (none? f (cdr things)))
@@ -221,3 +233,17 @@
       matchers
       (matchers things)
       t))
+
+; given an arg 'f, invoke 'f with no args
+(def self-invoke (f) (f))
+
+;; returns the first element of 'things iff it is the only element of 'things
+(def list-single-element (things)
+  (if (no (cdr things)) (car things)))
+
+;; like map, but function 'f takes two arguments: the thing and the 0-based index of the thing
+(def map-with-index (f things)
+  (let i -1
+    (map (fn (thing)
+             (f thing (++ i)))
+         things)))