puts the fun newLISP button back in Lisp


last updated 2014-11-25

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 Mac OS X 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) 

;

Check if a file is a link

; check if file is a link
; Mac OS X, Linux and BSDs, not on Win32
; see man page for fstat on Unix
; instead of octal 0120000 can use:
; 0xA000 hex or 40960 decimal
;
; example: 
;    (link? "Desktop") => true

(define (link? path-name) 
   (= 0120000 (& (file-info path-name 1) 0120000)))
;

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 OSX / 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 from newlisp.org
; @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 Fanda

(define (permutations items) 
  (if (empty? items) 
    '(()) 
    (apply append 
      (map (lambda (element) 
        (map 
          (lambda (permutation) 
             (cons element permutation)) 
          (permutations (replace element 
             (begin items))))) 
      items))))

; the (begin ..) wrapper makes replace non-destructive
; (permutations '(1 2 3)) 
; => ((1 2 3) (1 3 2) (2 1 3) 
;     (2 3 1) (3 1 2) (3 2 1))

Combinations

; e is the set of elements
; k is the number of elements to choose
; Contributed by Ted Walther, 2014
;
; (combinations '(a b c d) 3) => ((a b c) (a b d) (a c d) (b c d))
;
(define (combinations elem k (r '()))
  (if (= (length r) k)
    (list r)
    (let (rlst '())
      (dolist (x elem)
        (setq rlst (append rlst (combinations 
                                 ((+ 1 $idx) elem) k (append r (list x))))))
      rlst)))
;

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 ;;