newLISP - Code Snippets

puts the fun

back in Lisp

last updated 2015-9-17

Code Snippets

True random numbers from atmospheric noise

; generate 1000 random numbers between 1 and 10
;     (true-random 1000 1 10)

(define (true-random num from to)
    (let (params (format "num=%d&min=%d&max=%d&" num from to)
          pre "http://www.random.org/integers/?"
          post "col=1&base=10&format=plain&rnd=new")
      (map int (parse (get-url (append pre params post))))
    )
)
;

Reset the archive flag on Win32

; resets the Win32 archive flag on a file
; By CaveGuy 2009

(define (reset-archive-flag file-name)
  (if (not GetFileAttributesA)
    (begin
      (import "kernel32.DLL" "GetFileAttributesA")
      (import "kernel32.DLL" "SetFileAttributesA")))
    (setq fname file-name
      file-attrib (GetFileAttributesA (address fname))
      new-attrib (^ file-attrib (& file-attrib 0x20)))
  (SetFileAttributesA (address fname) new-attrib) )
;

Set the file time in Win32

; Given a full path to the source and destination
; file, FixFileTime will copy the FileTime info
; from the src file to the dest file.
; By CaveGuy 2009

(define (FixFileTime src dest , result)
   (unless SetFileTime
           (import "kernel32.DLL" "_lopen")
           (import "kernel32.DLL" "_lclose")
           (import "kernel32.DLL" "GetFileTime")
           (import "kernel32.DLL" "SetFileTime")
           (setq lpCreationTime 0
                 lpLastAccessTime 0
                 lpLastWriteTime 0))
   (setq hFileS (_lopen src 1)
         hFileD (_lopen dest 1) )
   (when (and (> hFileS 0) (> hFileD 0))
           (GetFileTime hFileS
               (address lpCreationTime)
               (address lpLastAccessTime)
               (address lpLastWriteTime) )
           (set 'result (SetFileTime hFileD
               (address lpCreationTime)
               (address lpLastAccessTime)
               (address lpLastWriteTime))))
   (if (> hFileS 0) (_lclose hFileS))
   (if (> hFileD 0) (_lclose hfileD))
   ;(if (zero? result) nil true))
   (not (zero? result)) )
;

URL encode and decode

; Character strings in URLs and POST data when
; using HTTP methods must not use certain unsafe
; characters. These routines encode and decode
; to save URL format.
;
; (url-encode "this is a test?")
;   => "this%20is%20a%20test%3F"
; (url-decode "this%20is%20a%20test%3F")
;   => "this is a test?"
;
; (url-encode "所有的愛是公平的")
; =>  "%e6%89%80%e6%9c%89%e7%9a%84%e6%84%9b%e6%98%af%e5%85%ac%e5%b9%b3%e7%9a%84"
; (url-decode (url-encode ""所有的愛是公平的")) => "所有的愛是公平的"

; simple encoder
(define (url-encode str)
  (replace {([^a-zA-Z0-9])} str (format "%%%2X" (char $1)) 0))

; UTF-8 encoder, encodes everything into %xx form
(define (url-encode str) ; for UTF-8 strings
  (join (map (fn (c) (format "%%%02x" c)) (unpack (dup "b" (length str)) str))))

; universal decoder, works for ASCII and UTF-8
  (define (url-decode url (opt nil))
    (if opt (replace "+" url " "))
    (replace "%([0-9a-f][0-9a-f])" url (pack "b" (int $1 0 16)) 1))

Write a HTML page of all links found

; write links.html with all links in page

(setq page (get-url "http://news.google.com"))

(write-file "links.html"
  (join (find-all
      "<a href=([^>]+)>([^>]*)</a>" page)
      "<br>\n"))
;

Load modules only once

; - include - loads a module from the standard location,
; but only loads the file if not already loaded.
; Also shows how to write functions with memory.
;
; example:
; (include "zlib.lsp")
; (include "sqlite3.lsp")
;
; include:modules => ("zlib.lsp" "sqlite3.lsp")

(define (include:include mdl)
  (unless (find mdl include:modules)
    (module mdl)
    (push mdl include:modules -1)))

; module is a predefined function since v.10.0

Get the type of an expression

; - type - function
; Returns the type of a newLISP expression.
; "cdecl" and "stdcall" are library functions.
; They behave like primitives but are not global.
;
; example:
; (type '(a b c)) => "list"

(define (type x)
  (let (types
         '("bool" "bool" "integer" "float"
           "string" "symbol" "context" "primitive"
           "import-simple" "import-libffi" "quote" "list" "lambda"
           "fexpr" "array"))
    (types (& 0xf ((dump x) 1)))))
;

Calculate Pi to N digits on UNIX

; - pi - calculate to n digits on Unix
;
; Calculate Pi to n digits on macOS and other
; Unix this requires the UNIX utility bc which is
; installed by default on most UNIX systems
;
; (pi 30)
; => "3.141592653589793238462643383276"

(define (pi n)
(replace "\\" (join (exec
(format "echo 'scale=%d; 4 * a(1)' | bc -ql" n))) ""))
;

Create memoizing Functions

; A memoizing function caches its result for faster
; retrieval when called with the same parameters
; again the following function makes a memoizing
; function from any built-in or user defined
; function with an arbitrary number of arguments.
;
; (memoize my-add add)
; (my-add 3 4) => 7
; (my-add 5 6) => 11
;
; (define (fibo n)
;    (if(< n 2) 1
;    (+  (fibo (- n 1))
;        (fibo (- n 2)))))
;
; (memoize fibo-m fibo)
;
; (time (fibo-m 25)) => 148
; (time (fibo-m 25)) => 0

(define-macro (memoize mem-func func)
  (set (sym mem-func mem-func)
    (letex ((f func) (c mem-func))
      (lambda ()
        (or (context c (string (args)))
            (context c (string (args))
                    (apply f (args))))
))))

; recursive fibo can be made even faster when also
; caching intermediate results occurring during
; recursion:
;
; (memoize fibo
;   (lambda (n)
;     (if(< n 2) 1
;       (+  (fibo (- n 1))
;           (fibo (- n 2))))))
;
; (time (fibo 80)) => 0.024 ; 24 micro seconds
; (fibo 80)        => 37889062373143906
;

Sort naturally

; sorts same letters followed by numbers in number
; order newLISP v9.2.5 minimum is required for ()
; return of find-all ported to newLISP by G. Fischer
;
; (natural-sort '("a10" "a2" "a1" "a14"))
;     => ("a1" "a2" "a10" "a14")

(define (natural-sort l)
  (let (natural-key (lambda (s) (filter true?
    (flat (transpose (list
            (parse s "[0-9]+" 0)
            (map int (find-all "[0-9]+" s))))))))
    (sort l (fn (x y) (< (natural-key x)
            (natural-key y))))
))
;

Set std I/O on Win32 into text or binary mode

; On Win32 CR-LF gets translated to LF on stdin
; and on stdout a CR is added in front of each LF
; the following puts std I/O into text mode.
; Binary mode is default on all versions of newLISP.

(import "msvcrt.dll" "_setmode")

(define O_BINARY 0x8000)
(define O_TEXT 0x4000)

(_setmode 0 O_TEXT)
;

Hide the Win32 console

; hide the Win32 console window
; posted by 'Sleeper'
;

(import "kernel32.dll" "FreeConsole")
(FreeConsole)

;

Start AppleScript from newLISP

; takes a piece of AppleScript and returns
; the output
;
; example:
;
; (osa {tell app "Finder" to display dialog
;            "hello world"})
;
; the first version returns an empty list on
; error second version returns error messages
; as part of the output

; discard error output
(define (osa str)
   (exec (format {osascript -e '%s' 2> /dev/null} str)))

; return error message in stdout
(define (osa str)
    (exec (format {osascript -e '%s' 2>&1 } str)))
;

Get a list of local IPs

; get all IPs assigned to this machine on Win32
; on Linux/UNIX use (exec "ifconfig")
;
; (get-ips)
; => ("192.168.2.254" "255.255.255.0" "192.168.2.94")
;
(define (get-ips , ips)
  (dolist (ln (exec "ipconfig")) ; ifconfig on mac OS / UNIX
    (if (find
      {\b\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\b} ln 0)
        (push $0 ips)))
  ips)
;

Clean out HTML really quick

; clean HTML tags
;
(define (clean-html page)
(replace "<[^>]*>" page "" 0))

try the following:

(clean-html (get-url "http://yahoo.com"))
;

Clean out HTML really perfect

; needs OpenSource lynx text browser
; available for all platforms
;
(define (html2text url)
(exec (string "lynx -dump " url " > /tmp/text-file"))
(read-file "/tmp/text-file"))

Show a directory tree

;
(define (show-tree dir)
  (dolist (nde (directory dir))
    (if (and (directory? (append dir "/" nde))
             (!= nde ".") (!= nde ".."))
        (show-tree (append dir "/" nde))
        (println (append dir "/" nde)))
  )
)

(show-tree ((main-args) 2))

(exit)
;

Apply functions to directories and files recursively

; apply-dir - applies a file and a directory function
; to all files and directories in dir
;
; USAGE:
;     (apply-to-dir <file-func> <dir-func> <root-dir>)
;
; EXAMPLE:
;     (apply-dir delete-file remove-dir "someDir")
;
; the example would delete all file and directories
; in someDir in the current directory
;

(define (apply-dir ffunc dfunc dir)
  (dolist (nde (directory dir))
    (if (and (directory? (append dir "/" nde))
             (!= nde ".") (!= nde ".."))
        (begin
          (apply-dir ffunc dfunc (append dir "/" nde))
          (dfunc (append dir "/" nde)))
        (ffunc (append dir "/" nde)))))
;

Run a newLISP script from a Windows .cmd file

; @rem Posted by alex
; @newlisp.exe "%~f0" %* & goto :EOF
# begin newlisp-program
(println "Hello World!")
(exit)
# end newlisp-program

Generate permutations of multisets

; Warren-Hanson algorithm for generating
; permutations of multisets.
;

(define (make-k-permutations k multiset)
(let ((pivots (unique multiset)))
  (if (= k 1)
    (map list pivots)
    (let ((acc '()))
      (dolist (p pivots)
        (let ((sub-multiset (remove1 p multiset)))
          (dolist (sub-perm
               (make-k-permutations (- k 1) sub-multiset))
            (push (cons p sub-perm) acc))))
       acc))))

(define (remove1 elt lst)
(let ((elt-pos (find elt lst)))
   (if elt-pos (pop lst elt-pos))
   lst))

; (make-k-permutations 2  '(1 2 3 2))
;  =>  ((3 2) (3 1) (2 2) (2 3) (2 1) (1 3) (1 2))
;

Permutations of a set

; posted by Ralph Ronnquist 2015

(define (permutations items)
(if (empty? items) '()
   (1 items)
   (let ((e (cons (first items))) (n (length items)))
     (flat (map (fn (p (i -1)) (collect (append (0 (inc i) p) e (i p)) n))
                (permutations (rest items)))
           1))
   (list items)))

; (permutations '(1 2 3))
; => ((1 2 3) (2 1 3) (2 3 1) (1 3 2) (3 1 2) (3 2 1))

Combinations

; items is the set of elements
; k is the number of elements to choose
; posted by Ralph Ronnquist 2015
;
; (combinations '(a b c d) 3) =>
;     ((b c d) (a c d) (a b c) (a b d))

(define (combinations items k)
(if (<= (length items) k) (list items)
   (= k 1) (map list items)
   (append (combinations (rest items) k)
           (map (curry cons (first items))
                (combinations (rest items) (dec k))))))
;

Binomial Coefficient

; Contributed by Ted Walther, 2014
;
; An efficient way to calculate binomial-coefficient
; fast algorithm less likely to overflow, translated
; from C code found here:
;   http://blog.plover.com/math/choose.html
; Based on algorithm found in "Lilavati", a treatise
; on arithmetic written about 850 years ago in India.
; The algorithm also appears in the article on "Algebra"
; from the first edition of the Encyclopaedia Britannica,
; published in 1768.
;
; (binomial-coefficient 3 2) => 3L
;
; (binomial-coefficient 1000000 5)
; => 8333250000291666250000200000L

(define (binomial-coefficient n k)
  (if (> k n)
    0
    (let (r 1L)
      (for (d 1 k)
        (setq r (/ (* r n) d)) (-- n))
      r)))
;

Format ordinal numbers

; Format ordinal numbers
;
; (ordinal 3) => "3rd"
; (ordinal 4) => "4th"
; (ordinal 65) => "65th"
;
; contributed by Ted Walther, 2014
;
(define (ordinal n)
  (let (nn (string n))
    (cond
      ((regex {1[123]$} nn) (string nn "th"))
      ((regex {1$} nn) (string nn "st"))
      ((regex {2$} nn) (string nn "nd"))
      ((regex {3$} nn) (string nn "rd"))
      ((regex {[4567890]$} nn) (string nn "th"))
      (true nn))))
(global 'ordinal)

Send email using UNIX sendmail

; send email - Linux/UNIX
;
; a very short alternative to the smtp.lsp module
; in the newLISP distribution, but needs 'sendmail'
; in your system in /usr/bin or /bin (on FreeBSD)
; most UNIX systems seem to have it.
;
(define (sendmail to from subject body)
   (exec "/usr/bin/sendmail -t"
    (format "To: %s\nFrom: %s\nSubject: %s\n\n%s"
       to from subject body)))

Add with alternating signs

; add with alternating signs:
; thanks to Rick for an improved, faster version
;
; (+- a b c d e .... n) is equivalent to
; a + b - c + d - e....n
;
; example:
;
; (+- 1 2 3 4 5)            => -1
; (apply +- (sequence 1 5)  => -1

(define (+-)
(let (signs (cons 1 (series 1 -1 (- (length (args)) 1))))
   (apply add (map mul signs (args)))))
;

Get the directory part of a filename

; get directory part of a filename
;
; example:
;
;  (dirname "/usr/etc/hosts") => "/usr/etc"
;  (dirname "c:\\WINDOWS\\system32\\chkdsk.exe")
;     => "c:/WINDOWS/system32"
;
; Note that MS Windows allows both / and \ as
; path separators
;

(define (dirname path)
(join (chop (parse path "/|\\\\" 0)) "/"))
;

Get file name part of filename

; get file name part of filename, strip
; directory part
;
; example:
; (basename "/usr/etc/hosts") => "hosts"
;

(define (basename path)
(last (parse path "/")))
;

Multiple list zipper

; transpose multiple lists into one
; thanks to Nigel et al
;
(define (zip)
(transpose (args)))

; (zip '(1 2 3) '(a b c) '(x y z))
; => ((1 a x) (2 b y) (3 c z))
;

Run a Win32 shell and hide window

; run a Win32 command shell program
; hiding the window at the same time

; (winexec 0 "open" "newlisp.exe" "" "" 0) ;hide
;
; (winexec 0 "open" "newlisp.exe" "" "" 1) ;display
;
; (winexec 0 "open" "newlisp.exe" "" "" 2) ;minimize
;
; The last two parameters before the mode number are
; command line parameters and startup directory the
; application assumes. Here the original API:
;
;  HINSTANCE ShellExecute(
;    HWND hwnd, // handle to parent window
;    LPCTSTR lpOperation, // operation to perform

;    LPCTSTR lpFile, // filename or folder name
;    LPCTSTR lpParameters, // executable-file params
;    LPCTSTR lpDirectory, // default directory
;    INT nShowCmd // whether file is shown opened
;    );
;
; the function uses an import from a Win32
; system library:

(define winexec
   (import "shell32.dll" "ShellExecuteA"))

; Note that 'process' also has an option for
; hiding/showing the launched process window.
; This make this function obsolete, but it is
; shown here as an example on how to import a
; Win32 function.

Hide/show window from inside script

(import "kernel32.dll" "GetConsoleWindow")
(import "user32.dll" "ShowWindow")
(constant 'SW_HIDE 0)
(constant 'SW_SHOW 5)

(setq hwndConsole (GetConsoleWindow))
(if-not (zero? hwndConsole)
(ShowWindow hwndConsole SW_HIDE)
)

;; eof ;;