nydp 0.5.1 → 0.6.0

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

@@ -1,32 +1,59 @@
 (chapter-start 'list-manipulation)
 
-(def list-length (things)
-  (if (atom? things) 1
-      things         (+ 1 (list-length (cdr things)))
-      0))
+;; each call to the name 'accfn-name with an arg will append the arg to the end of a list.
+;; This form returns the resulting list.
+;; Example (collect first names from a list of people)
+;;
+;;   (accum a (each person people (a person.firstname)))
+;;
+;; will return (Alice Bob Carol Declan Eliza Fionn)
+;;
+(mac accum (accfn-name . body)
+  (w/uniq (things last-cons)
+    `(with (,last-cons  (cons)
+             ,things     ,last-cons
+             ,accfn-name (fn (a)
+                           (= ,last-cons (cdr-set ,last-cons (cons a)))
+                           a)
+             accum-end   (fn (a)
+                           (= ,last-cons (cdr-set ,last-cons a))
+                           a))
+       ,@body
+       (cdr ,things))))
 
+(def list-length (things)
+  (let cc 0
+    (loop (pair? things)
+      (do
+        (++ cc)
+        (= things (cdr things))))
+    (if things (+ cc 1) cc)))
+
+;; slice 'things into a list of lists each with maximum 'slice-size items
 (def list-slices (things slice-size)
-     ; slice 'things into a list of lists each with maximum 'slice-size items
-     (chapter pagination)
-     (if things
-         (if (> slice-size (len things))
-             (list things)
-             (cons (firstn slice-size things)
-                   (list-slices (nthcdr slice-size things)
-                                slice-size)))
-         nil))
-
+  (chapter pagination)
+  (if things
+    (if (> slice-size (len things))
+      (list things)
+      (cons (firstn slice-size things)
+        (list-slices (nthcdr slice-size things)
+          slice-size)))
+    nil))
+
+;; return a new list with 'inbetween in between every element of 'things
 (def intersperse (inbetween things)
-  ; return a new list with 'inbetween in between every element of 'things
-  (if (and (pair? things) (cdr things))
-      (apply list (car things) inbetween
-             (intersperse inbetween (cdr things)))
-      things))
+  (accum i
+         (while (pair? things)
+           (i (car things))
+           (if (cdr things)
+               (i inbetween))
+           (= things (cdr things)))
+         (if things (accum-end 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)))
+;; returns (a b X c d X e f)
 (def intersperse-splicing (inbetween things)
   (apply joinlists (intersperse (list inbetween) things)))
 
@@ -34,15 +61,19 @@
 ;; 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)))
+(def collect-helper (f things res)
+  (loop (pair? things)
+        (do
+            (if (f (car things))
+                (= res (cdr-set res (cons (car things)))))
+            (= things (cdr things))))
+  (if (and things (f things))
+      (= res (cdr-set res things))))
+
+(def collect (f things)
+  (let res (cons)
+    (collect-helper f things res)
+    (cdr res)))
 
 (assign select collect)
 
@@ -57,28 +88,46 @@
 (def reject (f things)
   (collect !f things))
 
-(def each/build-expression (var things body othervars otherparams)
-  (w/uniq (xs c)
-          `(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))
-
+  (w/uniq xs
+    `(let ,xs ,things
+       (loop ,xs
+         (let ,var (car ,xs)
+           ,@body
+           (= ,xs (cdr ,xs)))))))
+
+;; repeatedly assigns an element of 'things to 'var, increments 'ivar,
+;; and executes 'body each time
 (mac each-with-index (ivar var things . body)
-  (each/build-expression var things body `(,ivar 0) `((+ ,ivar 1))))
+  (w/uniq xs
+    `(with (,xs ,things ,ivar 0)
+       (loop ,xs
+         (let ,var (car ,xs)
+           ,@body
+           (++ ,ivar)
+           (= ,xs (cdr ,xs)))))))
+
+
+;; used internally by 'reduce
+(def reduce-helper (f a things)
+  (loop (pair? things)
+        (= a      (f a (car things))
+           things (cdr things)))
+  (if things
+      (= a (f a things)))
+  a)
 
+;; applies f to each element of 'things and the result of f, returning the result
+;;
+;; for example, (reduce + '(1 2 3)) returns 6
+;;
 (def reduce (f things)
-  (rfnwith rd (acc (car things) list (cdr things))
-           (if (pair? list)
-               (rd (f acc (car list))
-                   (cdr list))
-               acc)))
+  (if (pair? things)
+      (reduce-helper f (car things) (cdr things))
+      things
+      (f things)))
 
 ;; t if this is a proper list (last cdr is nil)
 ;; nil otherwise (last cdr is neither cons nor nil)
@@ -94,17 +143,11 @@
                         (firstn (- n 1)
                                 (cdr things)))))
 
-(def nthcdr (n things)
-  ; returns the nth cdr of the list 'things
-  (if (> n 0)
-      (nthcdr (- n 1) (cdr things))
-      things))
-
+;; return a new list which is the concatenation of all the given lists
+;; 'things is a list
+;; 'more-thingses is a list of lists
+;; call like this: (joinlists '(a b c) '(x y z) '(1 2 3))
 (def joinlists (things . more-thingses)
-  ; return a new list which is the concatenation of all the given lists
-  ; 'things is a list
-  ; 'more-thingses is a list of lists
-  ; call like this: (joinlists '(a b c) '(x y z) '(1 2 3))
   (if things
       (cons (car things)
             (apply joinlists
@@ -113,28 +156,28 @@
       more-thingses
       (apply joinlists more-thingses)))
 
+(def detect-helper (f things found)
+  (loop (and (no found) (pair? things))
+    (let it (car things)
+      (= found (and (f it) (or it t))
+        things (cdr things))))
+  (if (and (no found) things)
+    (= found (and (f things) things)))
+  found)
+
+;; if 'f is a function,
+;;   if 'things is a list, return the first item in the list for which 'f returns non-nil
+;;   otherwise, return 'things if (f things) is non-nil
+;;   otherwise, nil
+;; if 'f is not a function, self-invoke with a function checking for equality with f
+;;
+;; WARNING: if the detected thing is nil, returns t instead. A return value of nil
+;; means the thing was not found ; non-nil means the thing was found, including when
+;; the found thing is itself nil.
 (def detect (f things)
-  ; if 'f is a function,
-  ;   if 'things is a list, return the first item in the list for which 'f returns non-nil
-  ;   otherwise, return 'things if (f things) is non-nil
-  ;   otherwise, nil
-  ; if 'f is not a function, self-invoke with a function checking for equality with f
-  ;
-  ; WARNING: if the detected thing is nil, returns t instead. A return value of nil
-  ; means the thing was not found ; non-nil means the thing was found, including when
-  ; the found thing is itself nil.
   (if (isa 'fn f)
-      (rfnwith d (items things)
-                 (if (pair? items)
-                     (let it (car items)
-                       (or
-                        (and (f it)
-                             (or it t))
-                        (d:cdr items)))
-                     (f items)
-                     items))
-      (detect (curry eq? f)
-              things)))
+      (detect-helper f things nil)
+      (detect-helper (fn (thing) (eq? f thing)) things nil)))
 
 ;; split things into a list of lists each n long
 (def tuples (n things)
@@ -148,7 +191,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))
+              (if (no b) a
+                  (no a) b
+                  (better-p a b) a b))
           things))
 
 (def min things (best < things))
@@ -235,9 +280,19 @@
       (matchers things)
       t))
 
-; given an arg 'f, invoke 'f with no args
+;; given an arg 'f, invoke 'f with no args
 (def self-invoke (f) (f))
 
+;; returns a function @r@ that takes one argument, @f@
+;; which when called, applies @f@ to the given @args@
+;;
+;; example: @(map (self-invoker 3) (list sqrt sqr ln inv exp fib fact))@
+;; returns (1.732 9 1.098 0.333 20.085 4 6)
+;; being respectively the sqrt, square, log, inverse, e**x, fibonacci, factorial of 3 (assuming such functions are previously defined)
+;;
+(def self-invoker args
+  λf(apply f args))
+
 ;; 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)))
@@ -247,3 +302,11 @@
   (let c (counter)
     (map (fn (thing) (f thing (c)))
          things)))
+
+;; takes a list of lists, returns a list of lists
+;; transforms ((1 2 3) (a b c) (+ - *)) into ((1 a +) (2 b -) (3 c *))
+;; the number of lists returned will be the number of items in the first of the given lists
+(def rotate-2d-array (list-of-lists)
+  (with (size (len:car list-of-lists)
+         maps (map (fn (i) (fn (things) (nth i things))) (range 0 size)))
+    (map (fn (mapper) (map mapper list-of-lists)) maps)))

data/lib/lisp/core-045-dox-utils.nydp

@@ -75,6 +75,7 @@ Examples for ~name
                nil
                target))))
 
+;; like mac-expand but only goes n steps
 (def explain-mac (n expr)
   (if (eq? n 0)
       expr

data/lib/lisp/core-050-test-runner.nydp

@@ -1,8 +1,8 @@
 (assign show-failed-only t)
 (assign all-tests nil)
 
+;; register a test to be run later by 'run-all-tests
 (def register-test (test)
-  ; register a test to be run later by 'run-all-tests
   (push test all-tests))
 
 (def run-all-tests (verbose)
@@ -37,17 +37,13 @@
                         (failf))))))
 
 (def execute-tests (desc tests passf failf verbose)
-  (execute-test desc
-                (car tests)
-                passf
-                failf
-                verbose)
-  (if (cdr tests)
-      (execute-tests desc
-                     (cdr tests)
-                     passf
-                     failf
-                     verbose)))
+  (while tests
+    (execute-test desc
+                  (car tests)
+                  passf
+                  failf
+                  verbose)
+    (= tests (cdr tests))))
 
 (mac examples-for (name . examples)
   (let suite-name "examples for ~(pp name)"

data/lib/lisp/core-070-prefix-list.nydp

@@ -1,4 +1,3 @@
-
 (assign prefix-list-prefixes ())
 
 (def prefix-match-fn (txt)
@@ -6,28 +5,33 @@
 
 (def find-prefix-rule (prefix)
   (cdr:detect (prefix-match-fn prefix)
-        prefix-list-prefixes))
+       prefix-list-prefixes))
 
+;; looks up a handler in 'prefix-list-prefixes
+;; whose 'car matches the prefix, and whose 'cdr
+;; is a function, which behaves like a macro, in that
+;; it processes the prefix name and the prefixed list,
+;; returning more code
 (mac prefix-list (prefix list)
-  ; looks up a handler in 'prefix-list-prefixes
-  ; whose 'car matches the prefix, and whose 'cdr
-  ; is a function, which behaves like a macro, in that
-  ; it processes the prefix name and the prefixed list,
-  ; returning more code
   (let handler (find-prefix-rule prefix)
-    (and handler (handler prefix list))))
+    (if handler
+        (handler prefix list)
+        (error "unknown prefix-list syntax : ~(inspect prefix)"))))
 
+;; define a macro to process a prefix-list where the prefix matches the given regex
+;; param: 'regex is the regex which should match the list prefix
+;; param: 'prefix-var is the variable whose value will be the actual matched prefix
+;; param: 'list-var is the variable whose value will be the corresponding list
+;; param: 'body the code which will actually transform the list
 (mac define-prefix-list-macro (regex prefix-var list-var . body)
-  ; define a macro to process a prefix-list where the prefix matches the given regex
-  ; param: 'regex is the regex which should match the list prefix
-  ; param: 'prefix-var is the variable whose value will be the actual matched prefix
-  ; param: 'list-var is the variable whose value will be the corresponding list
-  ; param: 'body the code which will actually transform the list
   `(push (cons ,regex (fn (,prefix-var ,list-var) ,@body))
          prefix-list-prefixes))
 
+;; allows (map λa(upcase a.name) people)
+;; as shortcut for (map (fn (a) (upcase a.name)) people)
 (define-prefix-list-macro "^λ.*" vars expr
-  ;; allows (map λa(upcase a.name) people)
-  ;; as shortcut for (map (fn (a) (upcase a.name)) people)
   (let var-list (map sym (collect !empty? (cdr:string-split vars "")))
     `(fn ,var-list ,expr)))
+
+(define-prefix-list-macro "\~" vars expr
+  `(to-string ,expr))

data/lib/lisp/core-080-pretty-print.nydp

@@ -74,8 +74,8 @@
                     'pp/def
                     (list "pretty-printer for forms starting with ~(quote ,name)")
                     ',args
-                    '(pp/def ,name ,args ,@body))))
-
+                    '(pp/def ,name ,args ,@body)
+                    (hash))))
 
 (pp/def string-pieces    (pp form indent) (pp/string-pieces pp (cdr form)))
 (pp/def quasiquote       (pp form indent) "`~(pp (cadr form) (cons "" indent))" )
@@ -85,7 +85,6 @@
 (pp/def comment          (pp form indent) "; ~(cadr form)\n")
 (pp/def prefix-list      (pp form indent) "~(cadr form)~(pp (caddr form))")
 
-
 (def pp/brace-list-pair (pp (k v) indent) "~k ~(pp v indent)")
 
 (pp/def brace-list (pp form indent)
@@ -124,7 +123,7 @@
   (cons (firstn n form)
         (map list (nthcdr n form))))
 
-(def pp/flatly (form)
+(def pp/flatly (form indent)
   (if (pair? form)
       (let special (hash-get pp/special-forms (car form))
         (if special
@@ -136,8 +135,15 @@
   (and (pair? form)
        (> (len:pp/flatly form) 40)))
 
+(def percent-syntax? (form)
+  (and (pair? form)
+       (sym? (car form))
+       (string-match (to-string (car form)) "^%")))
+
 (def pp/breaker (form)
-  (if (pair? form)
+  (if (percent-syntax? form)
+      (pp/split-form form 1)
+      (pair? form)
       (let key (car form)
         (if (or (eq? 'if key)
                 (eq? 'cond key))
@@ -164,6 +170,8 @@
 (def pp/indent (sym indent)
   (if (or (no sym) (pair? sym))
       indent
+      (string-match (to-string sym) "^%")
+      (cons " " indent)
       (cons (string-replace "." " " " ~sym") indent)))
 
 (def pprint (form indent)

data/lib/lisp/core-090-hook.nydp

@@ -1,37 +1,37 @@
 (chapter-start 'nydp/hooks "event management - execute a piece of code when something happens")
 
 (let hooks {}
+  ;; return the list of hook-names
   (def hook-names ()
-    ; return the list of hook-names
     (hash-keys hooks))
 
+  ;; return the list of hooks for 'hook-name
   (def hooks-for (hook-name)
-    ; return the list of hooks for 'hook-name
     hooks.,hook-name)
 
+  ;; add a function 'f to execute when 'hook-name is fired
   (def add-hook (hook-name f)
-    ; add a function 'f to execute when 'hook-name is fired
     (hash-cons hooks hook-name f))
 
+  ;; remove all hooks for 'hook-name
   (def clear-hooks (hook-name)
-    ; remove all hooks for 'hook-name
     (= hooks.,hook-name nil))
 
+  ;; temporarily remove all hooks for 'hook-name, restoring them after running 'f
   (def without-hooks (hook-name f)
-    ; temporarily remove all hooks for 'hook-name, restoring them after running 'f
     (let previous-hooks (hooks-for hook-name)
       (ensure (= hooks.,hook-name previous-hooks)
               (clear-hooks hook-name)
               (f))))
 
+  ;; only works if you have a reference to the original function
   (def remove-hook (hook-name f)
-    ; only works if you have a reference to the original function
     (= hooks.,hook-name
        (collect (curry !eq? f)
                hooks.,hook-name)))
 
+  ;; apply all functions attached to 'hook-name to given 'args
   (def run-hooks (hook-name . args)
-    ; apply all functions attached to 'hook-name to given 'args
     (each hook (hooks-for hook-name)
           (apply hook args))))
 
@@ -42,9 +42,9 @@
 ;;
 ;; same as (add-hook 'transaction (fn (account amount) (update account total (+ account.total amount))))
 ;;
-;; if 'body is nil and 'args is a symbol, for example
+;; if 'body is a symbol and 'args is nil, for example
 ;;
-;; (on transaction notify)
+;; (on transaction () notify)
 ;;
 ;; 'notify must be a predefined function accepting any arguments to the 'transaction event ; the example is equivalent to
 ;;
@@ -59,8 +59,8 @@
                   (car body)
                   `(fn ,args ,@body))
     (w/uniq dox-item
-      `(let ,dox-item (car:dox-lookup ',event)
-         (if (no ,dox-item) (error "unknown hook ~(just ',event)"))
+      `(let ,dox-item (or (car:dox-lookup ',event)
+                          (dox-add-doc ',event 'hook))
          (add-hook ',event ,hookfn)
          (hash-cons ,dox-item 'hooks
             { src      ',hookfn