From 260e90401d9b22c859b9c46b9746d2aa9534fecb Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Fri, 12 Jun 2015 11:50:59 +0200 Subject: [PATCH] Add samples for .l. array.l by NANRI southly; MIT license. simul.l by Alexander Burger; MIT license. --- samples/Common Lisp/array.l | 164 +++++++++++++++++++++++++++++++++++ samples/PicoLisp/simul.l | 165 ++++++++++++++++++++++++++++++++++++ 2 files changed, 329 insertions(+) create mode 100644 samples/Common Lisp/array.l create mode 100644 samples/PicoLisp/simul.l diff --git a/samples/Common Lisp/array.l b/samples/Common Lisp/array.l new file mode 100644 index 00000000..a64ac178 --- /dev/null +++ b/samples/Common Lisp/array.l @@ -0,0 +1,164 @@ +;;; -*- Mode: Lisp; Package: LISP -*- +;;; +;;; This file is part of xyzzy. +;;; + +(provide "array") + +(in-package "lisp") + +(export '(make-vector make-array vector array-dimensions array-in-bounds-p + upgraded-array-element-type adjust-array)) + +(defun upgraded-array-element-type (type) + (cond ((or (eq type 't) + (null type)) + 't) + ((member type '(character base-character standard-char + extended-character) :test #'eq) + 'character) + (t + (setq type (car (si:canonicalize-type type))) + (cond ((or (eq type 't) + (null type)) + 't) + ((member type '(character base-character standard-char + extended-character) :test #'eq) + 'character) + (t 't))))) + +(defun check-array-initialize-option (ies-p ics-p displaced-to) + (let ((x 0)) + (and ies-p (incf x)) + (and ics-p (incf x)) + (and displaced-to (incf x)) + (when (> x 1) + (error ":initial-element, :initial-contents, :displaced-to")))) + +(defun make-vector (length &key + (element-type t) + (initial-element nil ies-p) + (initial-contents nil ics-p) + fill-pointer + adjustable + displaced-to + (displaced-index-offset 0)) + (setq element-type (upgraded-array-element-type element-type)) + (check-array-initialize-option ies-p ics-p displaced-to) + (let ((vector (si:*make-vector length element-type initial-element adjustable + fill-pointer displaced-to displaced-index-offset))) + (when ics-p + (si:*copy-into-seq vector initial-contents)) + vector)) + +(defun make-array (dimensions &rest rest + &key + (element-type t) + (initial-element nil ies-p) + (initial-contents nil ics-p) + fill-pointer + adjustable + displaced-to + (displaced-index-offset 0)) + (cond ((integerp dimensions) + (apply #'make-vector dimensions rest)) + ((= (length dimensions) 1) + (apply #'make-vector (car dimensions) rest)) + (t + (setq element-type (upgraded-array-element-type element-type)) + (check-array-initialize-option ies-p ics-p displaced-to) + (when fill-pointer + (error ":fill-pointer")) + (let ((array (si:*make-array dimensions element-type + initial-element adjustable + displaced-to displaced-index-offset))) + (when ics-p + (let ((dims (make-list (array-rank array) + :initial-element 0)) + (stack (list initial-contents)) + (rank (1- (array-rank array)))) + (dolist (x dims) + (push (elt (car stack) 0) stack)) + (dotimes (i (array-total-size array)) + (setf (row-major-aref array i) (car stack)) + (do ((x dims (cdr x)) + (j rank (1- j))) + ((null x)) + (pop stack) + (incf (car x)) + (when (< (car x) (array-dimension array j)) + (do ((r (- rank j) (1- r))) + ((< r 0)) + (push (elt (car stack) (nth r dims)) stack)) + (return)) + (setf (car x) 0))))) + array)))) + +(defun vector (&rest list) + (make-vector (length list) :element-type t :initial-contents list)) + +(defun array-dimensions (array) + (do ((i (1- (array-rank array)) (1- i)) + (dims '())) + ((minusp i) dims) + (push (array-dimension array i) dims))) + +(defun array-in-bounds-p (array &rest subscripts) + (let ((r (array-rank array))) + (when (/= r (length subscripts)) + (error "subscripts: ~S" subscripts)) + (do ((i 0 (1+ i)) + (s subscripts (cdr s))) + ((= i r) t) + (unless (<= 0 (car s) (1- (array-dimension array i))) + (return nil))))) + +(defun adjust-array (old-array + dimensions + &rest rest + &key + (element-type nil ets-p) + initial-element + (initial-contents nil ics-p) + (fill-pointer nil fps-p) + displaced-to + displaced-index-offset) + (when (/= (length dimensions) (array-rank old-array)) + (error "?")) + (unless ets-p + (push (array-element-type old-array) rest) + (push :element-type rest)) + (when (adjustable-array-p old-array) + (push t rest) + (push :adjustable rest)) + (cond (fps-p + (unless (array-has-fill-pointer-p old-array) + (error "?"))) + (t + (when (array-has-fill-pointer-p old-array) + (push (fill-pointer old-array) rest) + (push :fill-pointer rest)))) + (when (eq old-array displaced-to) + (error "?")) + (let ((new-array (apply #'make-array dimensions rest))) + (or ics-p displaced-to + (copy-array-partially old-array new-array)) + (cond ((adjustable-array-p old-array) + (si:*replace-array old-array new-array) + old-array) + (t + new-array)))) + +(defun copy-array-partially (src dst) + (let* ((dims (mapcar #'min (array-dimensions src) (array-dimensions dst))) + (r (array-rank src)) + (s (make-list r :initial-element 0))) + (setq r (1- r)) + (dotimes (x (apply #'* dims)) + (setf (apply #'aref dst s) (apply #'aref src s)) + (do ((i r (1- i))) + ((minusp i)) + (incf (nth i s)) + (when (< (nth i s) (nth i dims)) + (return)) + (setf (nth i s) 0))))) diff --git a/samples/PicoLisp/simul.l b/samples/PicoLisp/simul.l new file mode 100644 index 00000000..df4c219c --- /dev/null +++ b/samples/PicoLisp/simul.l @@ -0,0 +1,165 @@ +# 11dec13abu +# (c) Software Lab. Alexander Burger + +(de permute (Lst) + (ifn (cdr Lst) + (cons Lst) + (mapcan + '((X) + (mapcar + '((Y) (cons X Y)) + (permute (delete X Lst)) ) ) + Lst ) ) ) + +(de subsets (N Lst) + (cond + ((=0 N) '(NIL)) + ((not Lst)) + (T + (conc + (mapcar + '((X) (cons (car Lst) X)) + (subsets (dec N) (cdr Lst)) ) + (subsets N (cdr Lst)) ) ) ) ) + +(de shuffle (Lst) + (by '(NIL (rand)) sort Lst) ) + +(de samples (Cnt Lst) + (make + (until (=0 Cnt) + (when (>= Cnt (rand 1 (length Lst))) + (link (car Lst)) + (dec 'Cnt) ) + (pop 'Lst) ) ) ) + + +# Genetic Algorithm +(de gen ("Pop" "Cond" "Re" "Mu" "Se") + (until ("Cond" "Pop") + (for ("P" "Pop" "P" (cdr "P")) + (set "P" + (maxi "Se" # Selection + (make + (for ("P" "Pop" "P") + (rot "P" (rand 1 (length "P"))) + (link # Recombination + Mutation + ("Mu" ("Re" (pop '"P") (pop '"P"))) ) ) ) ) ) ) ) + (maxi "Se" "Pop") ) + + +# Alpha-Beta tree search +(de game ("Flg" "Cnt" "Moves" "Move" "Cost") + (let ("Alpha" '(1000000) "Beta" -1000000) + (recur ("Flg" "Cnt" "Alpha" "Beta") + (let? "Lst" ("Moves" "Flg") + (if (=0 (dec '"Cnt")) + (loop + ("Move" (caar "Lst")) + (setq "*Val" (list ("Cost" "Flg") (car "Lst"))) + ("Move" (cdar "Lst")) + (T (>= "Beta" (car "*Val")) + (cons "Beta" (car "Lst") (cdr "Alpha")) ) + (when (> (car "Alpha") (car "*Val")) + (setq "Alpha" "*Val") ) + (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) + (setq "Lst" + (sort + (mapcar + '(("Mov") + (prog2 + ("Move" (car "Mov")) + (cons ("Cost" "Flg") "Mov") + ("Move" (cdr "Mov")) ) ) + "Lst" ) ) ) + (loop + ("Move" (cadar "Lst")) + (setq "*Val" + (if (recurse (not "Flg") "Cnt" (cons (- "Beta")) (- (car "Alpha"))) + (cons (- (car @)) (cdar "Lst") (cdr @)) + (list (caar "Lst") (cdar "Lst")) ) ) + ("Move" (cddar "Lst")) + (T (>= "Beta" (car "*Val")) + (cons "Beta" (cdar "Lst") (cdr "Alpha")) ) + (when (> (car "Alpha") (car "*Val")) + (setq "Alpha" "*Val") ) + (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) ) ) ) ) ) + + +### Grids ### +(de grid (DX DY FX FY) + (let Grid + (make + (for X DX + (link + (make + (for Y DY + (set + (link + (if (> DX 26) + (box) + (intern (pack (char (+ X 96)) Y)) ) ) + (cons (cons) (cons)) ) ) ) ) ) ) + (let West (and FX (last Grid)) + (for (Lst Grid Lst) + (let + (Col (pop 'Lst) + East (or (car Lst) (and FX (car Grid))) + South (and FY (last Col)) ) + (for (L Col L) + (with (pop 'L) + (set (: 0 1) (pop 'West)) # west + (con (: 0 1) (pop 'East)) # east + (set (: 0 -1) South) # south + (con (: 0 -1) # north + (or (car L) (and FY (car Col))) ) + (setq South This) ) ) + (setq West Col) ) ) ) + Grid ) ) + +(de west (This) + (: 0 1 1) ) + +(de east (This) + (: 0 1 -1) ) + +(de south (This) + (: 0 -1 1) ) + +(de north (This) + (: 0 -1 -1) ) + +(de disp ("Grid" "How" "Fun" "X" "Y" "DX" "DY") + (setq "Grid" + (if "X" + (mapcar + '((L) (flip (head "DY" (nth L "Y")))) + (head "DX" (nth "Grid" "X")) ) + (mapcar reverse "Grid") ) ) + (let (N (+ (length (cdar "Grid")) (or "Y" 1)) Sp (length N)) + ("border" north) + (while (caar "Grid") + (prin " " (align Sp N) " " + (and "How" (if (and (nT "How") (west (caar "Grid"))) " " '|)) ) + (for L "Grid" + (prin + ("Fun" (car L)) + (and "How" (if (and (nT "How") (east (car L))) " " '|)) ) ) + (prinl) + ("border" south) + (map pop "Grid") + (dec 'N) ) + (unless (> (default "X" 1) 26) + (space (inc Sp)) + (for @ "Grid" + (prin " " (and "How" " ") (char (+ 96 "X"))) + (T (> (inc '"X") 26)) ) + (prinl) ) ) ) + +(de "border" (Dir) + (when "How" + (space Sp) + (prin " +") + (for L "Grid" + (prin (if (and (nT "How") (Dir (car L))) " +" "---+")) ) + (prinl) ) )