; a trivial P2P file sharing program written in newLISP for demo purpose
;
; based on ideas from http://www.freedom-to-tinker.com/tinyp2p.html
; and http://ansuz.sooke.bc.ca/software/molester/ and
; http://ansuz.sooke.bc.ca/software/molester/2005010301.php
;
; command reference
; i/ advertise presence of your node to the peer
; g<filename>/ requests a file
; f<message> forward to peers
; h/ gets list of all peers
;
; used internally
; e<filename>/ expect a file
; x sent after receiving a file to make sure
;
; the program below is a toy, not a serious p2p program.
;
; differences from original mole-ster:
; use of 'x' -- to allow data receipt on receiving side when file is sent
; data is read in 8k chunks at a time. this is to avoid having to read
; the entire file into a buffer before writing. it allows larger files to be
; transferred.
;
; more more information refer to the original mole-ster web sites.
;

(context 'P2P)

(constant 'SIGINT 2)
(define (interrupted)
  (println "interruted by user!")
  (exit))

(signal SIGINT interrupted)

(set 'my-address "")
(set 'my-password "")
(set 'peers '())

(define (get-addr addr-and-port)  (regex "(.*):(.*)" addr-and-port)  $1)
(define (get-port addr-and-port)  (regex "(.*):(.*)" addr-and-port)  (integer $2))

(define (op-send dest-addr source-addr filename data)
  (if (set 'socket (net-connect (get-addr dest-addr) (get-port dest-addr)))
      (begin
			(net-send socket (format "%s %s %s/" my-password source-addr filename))
			(net-send socket data )
			(if (!= data "")
				(net-receive socket 'buf 1))
			(close socket))))

(define (P2P:P2P my-password peer-address my-address commands )
  (set 'peers (append peers (list peer-address)))
  (dolist (cmd commands)  (op-send peer-address my-address cmd ""))
  (set 'socket (net-listen  (get-port my-address)))
  (while true 
	 (while  (and (not (net-error)) (not (net-select socket "read" 1000)))
		 (if (net-error) (print (net-error))))
	 (set 'peer-socket (net-accept socket)) (net-receive peer-socket 'buf 1024 "/") 
	 (regex "^([a-zA-Z0-9]*) ([0-9:.]*) ([e-i])([^/]*)(/)" buf) 
	 (set 'peer-password $1) 
	 (set 'peer-address $2) 
	 (set 'peer-command $3) 
	 (set 'requested-filename $4) 
	 (set 'data $6) 
	 (if (= peer-password my-password) 
	     (case peer-command
	       ("e" (begin
	       			(set 'finished false)
	       			(while (not finished)
	       		     	(while (and (not (net-error)) (not (net-select peer-socket "read" 1000)))
	       		     		(if (net-error) (print (net-error))))
			    		(if (!= nil (net-receive peer-socket 'input-data 8192))
			    			(begin
								(append-file  requested-filename input-data)
							(set 'finished true)))
					(net-send socket "x")))
	       ("f"  (dolist (peer peers)   (op-send peer my-address requested-filename data)))
	       ("g" (op-send peer-address my-address (append "e" requested-filename) 
	       			(read-file requested-filename)))
	       ("h" (dolist (peer peers)  (op-send peer-address peer "i" "")))
	       ("i" (append peers peer-address))))
	 (close peer-socket)))

(context 'MAIN)


(P2P:P2P (main-args 2) (main-args 3) (main-args 4)  (slice (main-args) 5 -1))

// simple newLISP code to fetch interesting pictures from
// flickr and display on the monitor using TK

(set 'api "/services/rest")
(set 'apikey "YOUR-OWN-KEY-HERE")
(set 'host "http://flickr.com")
(set 'email "")
(set 'password "")

(define (doget method auth params)
  (setq url (append host api "/?api_key=" apikey "&method=" method))
  (if (list? params) 
   (setq url (append url "&" (urlencode params))))
  (if (not (nil? auth)) 
   (setq url (append url "&email=" email "&password=" password)))
  (setq xmldata (get-url url)))


(define (urlencode params)
  (setq urlstring "")
  (dolist (param1 params) 
   (if (not (= urlstring "")) 
    (setq urlstring (append urlstring "&"))) 
   (setq urlstring (append urlstring (nth 0 param1) "=" (nth 1 param1)))))

(define (xmlconvert data)
  (xml-type-tags nil nil nil nil)
  (setq sxmldata (xml-parse data (+ 1 2 4 8 16))))
  
(define (getphotos data)
  (if (ref 'photo sxmldata) 
   (setq photolist (slice (data (chop (ref 'photo data) 2)) 2 -1)) 
   (setq photolist '())))

(define (handlephotos sxmldata)
  (dolist (aphoto (getphotos sxmldata)) 
   (setq pr (first (rest aphoto))) 
   (print (format "http://static.flickr.com/%s/%s_%s_o.jpg" (lookup 
      'server pr) 
     (lookup 'id pr) 
     (lookup 'secret pr)))))

(define (fiv)
  (tk "package require Img")
  (tk "destroy .fivwin")
  (tk "toplevel  .fivwin")
  
  (tk "wm geometry .fivwin [winfo screenwidth .]x[winfo screenheight .]+0+0")
  
  ;; uncomment the following lines to make display "fullscreen"
  ;;(tk "bind .fivwin <Key> {destroy .fivwin}")
  ;;(tk "bind .fivwin <Motion> {destroy .fivwin}")
  ;;(tk "bind .fivwin <Button> {destroy .fivwin}")
  ;;(tk "wm overrideredirect .fivwin yes; focus -force .fivwin")

  (setq picture (tk "image create photo "))
  (tk (append "label .fivwin.picture  -image " picture))
  (tk "pack .fivwin.picture")

  (setq xmldata
            (doget "flickr.interestingness.getList" nil  
             '(("per_page" "100")("page" "1"))))		;; how many per page , from which page
  (setq sxmldata (xmlconvert xmldata))
  
  (if (ref 'photo sxmldata) 
   (setq photolist (slice (sxmldata (chop (ref 'photo sxmldata) 2)) 2 -1)) 
   (exit))
   
  (dolist (aphoto photolist)
  	(if (= "0" (tk "winfo exists .fivwin"))
  		(exit))
    (setq photodesc (first (rest aphoto)))
    (setq photourl (format "http://static.flickr.com/%s/%s_%s_o.jpg" 
                            (lookup 'server photodesc)
                            (lookup 'id photodesc)
                            (lookup 'secret photodesc)))
    (tk "update idletasks")

    (setq file (last (parse photourl "/")))
    (write-file file (get-url photourl))
    (tk (append picture " configure -file " file))
     (delete-file file)))
 

Generates a list containting the fibonacci-sequence out to n. It is also a memoizing function so a second call to the same n will be greatly faster.

(let ((cache (make-hash-table :test #'equal)))
	     (defun fibonacci-sequence (n)
	       "Calculates the a Fibonacci Sequence of n integers."
	       (declare (optimize speed))
	       (declare (type number n))
	       (labels ((get-fib (x seq)
			  (if (= x n)
			      (setf (gethash n cache) (nreverse seq))
			      (if (cdr seq)
				  (get-fib (+ x 1) (push (+ (first seq)
							    (second seq))
							 seq))
				  (get-fib (+ x 1) (push 1 seq))))))
		 (or (gethash n cache)
		     (get-fib 0 nil))))
	     (defun fib-hash (n)
	       (gethash n cache))
	     (defun fib-clear ()
	       (setf cache (make-hash-table :test #'equal))))

The notion of a 'pair' in lisp. A 'pair' is a way of glueing two pieces of data.

(define z (cons x y))
(car z) => x
(cdr z) => y

The interesting thing is that any triple of procedures that satisfies the above condition can be used as the basis for implementing pairs. This is one such triple:

(define (cons x y)
(lambda (m) (m x y)))

(define (car z)
(z (lambda (p q) p)))

(define (cdr z)
(z (lambda (p q) q)))

Implementation of cons, car, and cdr without using any data structures at all but only using procedures. This blurs the distinction between 'procedure' and 'data'.