mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
Add samples for .l.
array.l by NANRI southly; MIT license. simul.l by Alexander Burger; MIT license.
This commit is contained in:
Lars Brinkhoff
164
samples/Common Lisp/array.l
Normal file
164
samples/Common Lisp/array.l
Normal file
@@ -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)))))
|
||||||
165
samples/PicoLisp/simul.l
Normal file
165
samples/PicoLisp/simul.l
Normal file
@@ -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) ) )
|
||||||
Reference in New Issue
Block a user