nydp 0.4.2 → 0.5.1

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

@@ -13,9 +13,9 @@
   `(ensuring (fn () ,protection)
              (fn ()    ,@body)))
 
+;; tests 'test, as long as 'test is non-nil,
+;; repeatedly executes 'body
 (mac while (test . body)
-  ; tests 'test, as long as 'test is non-nil,
-  ; repeatedly executes 'body
   (w/uniq (rfname pred)
     `(rfnwith ,rfname (,pred ,test)
         (when ,pred
@@ -40,12 +40,21 @@
        (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.
@@ -56,13 +65,31 @@
                  (let ,v (hash-get ,h ,k)
                    (or ,v (returnlet ,v ,val (hash-set ,h ,k ,v)))))))
 
+;; same as 'def, but caches the result, keyed on args, so for a given set of args the result
+;; is only ever calculated once
+;;
+;; WARNING: in current incarnation, won't work with destructuring args
 (mac defmemo (name args . body)
-  ; same as 'def, but caches the result, keyed on args, so for a given set of args the result
-  ; is only ever calculated once
-  (let forms (filter-forms (build-def-hash (hash)) body)
+  (let forms (filter-forms (build-def-hash) body)
     (w/uniq h
             `(let ,h (hash)
                (def ,name ,args
                  ,@(map (fn (c) (cons 'comment c)) forms.comment)
                  ,@(map (fn (c) (cons 'chapter c)) forms.chapter)
                  (cache-get ,h (list ,@args) (do ,@(hash-get forms nil))))))))
+
+;; memoises a function expression
+;; args: the function arguments
+;; body: a list of function body expressions
+;; next: a function to assemble a function expression from 'args and 'body
+;; returns whatever 'next returns, where 'body is memoised based on the value of 'args
+(def memoise (args body next)
+  (let (memo newbody) (filter-remove '#memoise body)
+    (if memo
+        (w/uniq h
+                `(let ,h (hash) ,(next args `((cache-get ,h (list ,@args) (do ,@newbody))))))
+        (next args body))))
+
+(assign fun/expanders
+        (cons
+         (cons 'memoise memoise) fun/expanders))

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

@@ -13,6 +13,17 @@
        (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)
@@ -29,6 +40,7 @@
           (rfnwith flattenize (x things)
                    (if (pair? x)
                        (eachr flattenize x)
+                       x
                        (push (f x) acc)))
           acc))
 

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,21 +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))
 
-; return a function that always returns 'arg, similar to K in SKI calculus
+;; 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)
@@ -37,8 +36,8 @@
 
 (assign dynamics (hash))
 
+;; creates a dynamic variable.
 (mac dynamic (name initial)
-  ; creates a dynamic variable.
   (let with-mac-name (sym:+ "w/" name)
     (w/uniq prev
       `(do
@@ -53,10 +52,10 @@
          (def ,name () (hash-get (thread-locals) ',name))))))
 
 
-; overrides 'privately defined earlier in documentation manager
+;; overrides 'privately defined earlier in documentation manager
 (dynamic privately)
 
-; suppress documentation of anything defined in 'body
+;; suppress documentation of anything defined in 'body
 (mac in-private body
   `(w/privately t ,@body))
 
@@ -91,3 +90,24 @@
   (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))
+
+;; returns a function that returns a number sequence. Example:
+;; (let c (counter)
+;;   (p (c))           ;;=> 0
+;;   (p (c))           ;;=> 1
+;;   (p (c)))          ;;=> 2
+;;
+(def counter ()
+  (let i -1
+    (fn () (++ i))))

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

@@ -2,7 +2,7 @@
 
 ; 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)
@@ -30,3 +30,27 @@
 ; 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,72 @@
              (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))
 
-(def nth (n things)
-  ; returns the n-th item in the list 'things
-  (if (eq? n 0)
-      (car things)
-      (nth (- n 1) (cdr things))))
-
-(mac each (var things . body)
-  ; repeatedly assigns an element of 'things to 'var,
-  ; and executes 'body each time
+(def each/build-expression (var things body othervars otherparams)
   (w/uniq (xs c)
-          `((rfn ,c (,xs)
-                (if (pair? ,xs)
-                    (do (let ,var (car ,xs) ,@body)
-                        (,c (cdr ,xs)))))
-           ,things)))
+          `(rfnwith ,c (,xs ,things ,@othervars)
+               (if (pair? ,xs)
+                   (let ,var (car ,xs)
+                     ,@body
+                     (,c (cdr ,xs) ,@otherparams))))))
+
+;; repeatedly assigns an element of 'things to 'var,
+;; and executes 'body each time
+(mac each (var things . body)
+  (each/build-expression var things body))
 
-(def reduce (f things)
-  ((rfn rd (acc list)
-        (if (pair? list)
-            (rd (f acc (car list))
-                (cdr list))
-            acc))
-   (car things) (cdr things)))
+(mac each-with-index (ivar var things . body)
+  (each/build-expression var things body `(,ivar 0) `((+ ,ivar 1))))
 
+(def reduce (f 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,25 +136,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 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)
@@ -167,8 +177,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)
@@ -177,8 +199,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)
@@ -186,8 +208,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)
@@ -195,8 +217,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)))
@@ -215,3 +237,13 @@
 
 ; 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 c (counter)
+    (map (fn (thing) (f thing (c)))
+         things)))