validate moves and move pieces on the board in Lisp - lisp

I have this board [10,10] for this project below and I can't move the piece on the board
this question is part of the other questions about Lisp, you can see on my profile
(defun board ()
"T in position x=0 and y=0"
'(
(T 25 54 89 21 8 36 14 41 96)
(78 47 56 23 5 NIL 13 12 26 60)
(0 27 17 83 34 93 74 52 45 80)
(69 9 77 95 55 39 91 73 57 30)
(24 15 22 86 1 11 68 79 76 72)
(81 48 32 2 64 16 50 37 29 71)
(99 51 6 18 53 28 7 63 10 88)
(59 42 46 85 90 75 87 43 20 31)
(3 61 58 44 65 82 19 4 35 62)
(33 70 84 40 66 38 92 67 98 97)
)
)
not the same but similar here the rows begin at 1 but in project is start by 0
and this function to print the board
(defun print-board (board)
(format T "~%")
(mapcar (lambda (x) (format T " ~A ~%" x)) board)
(format nil ""))
I have 8 movements implemented but I only put 4 examples for the
question not to get too much code
(defun UP-LEFT (x y board)
"Function that receives 2 indexes and board, validate movement and move piece up and left"
(cond
((equal (validate-movements (- x 1) (- y 2) board) 0)
(move-piece x y -1 -2 board))
(T nil)))
(defun UP-RIGHT (x y board)
"receive 2 indexes and board, validate movement and move piece up and right"
(cond
((equal (validate-movements (+ x 1) (- y 2) board) 0)
(move-piece x y 1 -2 board))
(T nil)))
(defun LEFT-DOWN (x y board)
"Function that receives 2 indexes and board, validate movement and move piece left and down"
(cond
((equal (validate-movements (- x 2) (+ y 1) board) 0)
(move-piece x y -2 1 board))
(T nil)))
(defun LEFT-UP (x y board)
"Function that receives 2 indexes and board, validate movement and move piece left and up"
(cond
((equal (validate-movements (- x 2) (- y 1) board) 0)
(move-piece x y -2 -1 board))
(T nil)))
(defun DOWN-RIGHT (x y board)
"Function that receives 2 indexes and board, validate movement and move piece down and right"
(cond
((equal (validate-movements (+ x 1) (+ y 2) board) 0)
(move-piece x y 1 2 board))
(T nil)))
my doubt is in this move piece in board in axis (x,y)
(defun move-piece (x y dx dy board)
"Function that receives two indexes and board to move the piece on the board"
(mapcar
(lambda (L)
(cond
((atom L) L)
((and
(equal (nth 0 L) x)
(equal (nth 1 L) y))
(list (+ (nth 0 L) dx) (+ (nth 1 L) dy) (nth 2 L)
(nth 3 L) (nth 4 L) (nth 5 L) (nth 6 L)
(nth 7 L) (nth 8 L) (nth 9 L)))
(T L))) board))
and this function to validate movements
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(cond
((and
;; validation of rows and columns
(>= x 0)
(>= y 0)
(<= x 9)
(<= y 9)
(= (apply '+ (mapcar (lambda (L)
(cond
((atom L) 0)
((or (not(equal (nth 0 L ) x)) (not (equal (nth 1 L) y))) 0)
(T 1))) board)) 0)) 0)
(T nil )))
when I try to test the movements https://ideone.com/jaeCLu it's not move,
because don´t return nothing and show nothing
what I´m doing wrong?

Let's take a look at the validation function. First, make sensible limebreaks: when a multiline form is closed, break the line.
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(cond ((and
;; validation of rows and columns
(>= x 0)
(>= y 0)
(<= x 9)
(<= y 9)
(= (apply '+
(mapcar (lambda (L)
(cond ((atom L) 0)
((or (not (equal (nth 0 L ) x))
(not (equal (nth 1 L) y)))
0)
(T 1)))
board))
0))
0)
(T nil )))
A condition that has only two possible outcomes is better handled through if:
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(if (and
;; validation of rows and columns
(>= x 0)
(>= y 0)
(<= x 9)
(<= y 9)
(= (apply '+
(mapcar (lambda (L)
(cond ((atom L) 0)
((or (not (equal (nth 0 L ) x))
(not (equal (nth 1 L) y)))
0)
(T 1)))
board))
0))
0
nil))
Comparators like <= can take more arguments:
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(if (and (<= 0 x 9)
(<= 0 y 9)
(= (apply '+
(mapcar (lambda (L)
(cond ((atom L) 0)
((or (not (equal (nth 0 L) x))
(not (equal (nth 1 L) y)))
0)
(T 1)))
board))
0))
0
nil))
Since your board is a list of lists (one 10-element sublist per line), a line will never be an atom:
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(if (and (<= 0 x 9)
(<= 0 y 9)
(= (apply '+
(mapcar (lambda (L)
(cond ((or (not (equal (nth 0 L) x))
(not (equal (nth 1 L) y)))
0)
(T 1)))
board))
0))
0
nil))
Again, a two-clause conditional is better an if:
(defun validate-movements (x y board)
"Function that receives two indexes and board to validate movement"
(if (and (<= 0 x 9)
(<= 0 y 9)
(= (apply '+
(mapcar (lambda (L)
(if (or (not (equal (nth 0 L) x))
(not (equal (nth 1 L) y)))
0
1))
board))
0))
0
nil))
Now, I wanted to tell you how booleans are much easier to express logic with. However, that condition makes no sense to me: you seem to check that there is some line on the board that carries the x coordinate in its first field and the y coordinate in the second.
Maybe you wanted to check that the target coordinate is empty?
(defun target-valid-p (x y board)
(and (<= 0 x 9)
(<= 0 y 9)
(null (nth x (nth y board)))))
Next, the move function. Again, linebreaks:
(defun move-piece (x y dx dy board)
"Function that receives two indexes and board to move the piece on the board"
(mapcar (lambda (L)
(cond
((atom L) L)
((and (equal (nth 0 L) x)
(equal (nth 1 L) y))
(list (+ (nth 0 L) dx) (+ (nth 1 L) dy) (nth 2 L)
(nth 3 L) (nth 4 L) (nth 5 L) (nth 6 L)
(nth 7 L) (nth 8 L) (nth 9 L)))
(T L)))
board))
Your lines are never atoms:
(defun move-piece (x y dx dy board)
"Function that receives two indexes and board to move the piece on the board"
(mapcar (lambda (L)
(cond
((and (equal (nth 0 L) x)
(equal (nth 1 L) y))
(list (+ (nth 0 L) dx) (+ (nth 1 L) dy) (nth 2 L)
(nth 3 L) (nth 4 L) (nth 5 L) (nth 6 L)
(nth 7 L) (nth 8 L) (nth 9 L)))
(T L)))
board))
Two-branch conditional is if:
(defun move-piece (x y dx dy board)
"Function that receives two indexes and board to move the piece on the board"
(mapcar (lambda (L)
(if (and (equal (nth 0 L) x)
(equal (nth 1 L) y))
(list (+ (nth 0 L) dx) (+ (nth 1 L) dy) (nth 2 L)
(nth 3 L) (nth 4 L) (nth 5 L) (nth 6 L)
(nth 7 L) (nth 8 L) (nth 9 L))
L))
board))
Use list* and nthcdr to update part of a list:
(defun move-piece (x y dx dy board)
"Function that receives two indexes and board to move the piece on the board"
(mapcar (lambda (L)
(if (and (equal (nth 0 L) x)
(equal (nth 1 L) y))
(list* (+ (nth 0 L) dx)
(+ (nth 1 L) dy)
(nthcdr 2 L))
L))
board))
Now it seems that you again just update the first two cells of the line. Maybe I didn't understand your data model, but I would have thought that you just want to update the cells at the given coordinates:
(defun move-piece (x y dx dy board)
(let ((new-board (copy-tree board))
(new-x (+ x dx))
(new-y (+ y dy))
(piece (nth x (nth y board))))
(setf (nth x (nth y new-board)) nil
(nth new-x (nth new-y new-board)) piece)
new-board))

Related

Best way to implement rook moves and possible moves in Lisp

I have board [8,8] and I'm trying to implement the horizontal movement and vertical movement based on the movements up, down, left and right, movements of a rook on a chessboard and I am having difficulty in how to move piece to square with the number of square to move.
(defun board ()
'((64 35 74 26 21 57 12 28)
(43 15 47 53 24 56 42 29)
(51 41 71 31 17 45 55 30)
(67 66 22 T 54 75 32 38)
(13 11 16 23 25 27 33 20)
(34 36 37 44 46 52 61 48)
(10 49 59 69 68 70 50 40)
(62 63 65 72 73 76 77 58)))
The Rook moves horizontally and vertically any number of squares, forwards or backwards. In the diagram the Rook can move to any of the highlighted squares.
Function to check if the coordinates are valid
(defun position-valid (x y)
(and (>= x 0) (>= y 0) (< x 8) (< y 8)))
Function that will move the tower according to the coordinates (x, y)
(defun move-piece (x y dx dy board)
(let ((new-board (copy-tree board))
(new-x (+ x dx))
(new-y (+ y dy))
(piece (nth x (nth y board))))
(setf (nth x (nth y new-board)) nil
(nth new-x (nth new-y new-board)) piece)
new-board))
Function that moves the piece down
(defun DOWN (x y board)
(cond
((equal (position-valid (+ x 1) (+ y 0)) 'T)
(move-piece x y 1 0 board))
(T NIL)))
Function that moves the piece to up
(defun UP (x y board)
(cond
((equal (position-valid (- x 1) (+ y 0)) 'T)
(move-piece x y -1 0 board))
(T NIL)))
Function that moves the piece to the left
(defun LEFT (x y board)
(cond
((equal (position-valid (+ x 0) (- y 1)) 'T)
(move-piece x y 0 -1 board))
(T NIL)))
Function that moves the piece to the right
(defun RIGHT (x y board)
(cond
((equal (position-valid (+ x 0) (+ y 1)) 'T)
(move-piece x y 0 1 board))
(T NIL)))
now the goal is to implement the vertical and horizontal movements based on the movements mentioned above so that the piece is moved and in this case, I think that we still need to implement the possible moves based on the type of movement and how many squares to move
I implemented this list of operators for horizontal and vertical movement but it is not working
Function that moves the Tower horizontally
(defun HORIZONTAL (x y n mov board) ;;n is number of square to move
(cond
((and (equal (position-valid (+ x 0) (- y 1)) 'T) ;;left
(equal (position-valid (+ x 0) (+ y 1)) 'T));;right
(cond
((equal mov 'LEFT) (LEFT x y board))
((equal mov 'RIGHT) (RIGTH x y board))
(T (HORIZONTAL x y (1- n) mov board))))
(T NIL)))
Function that makes the Tower move in the vertical direction,
(defun VERTICAL(x y n mov board) ;;n is number of square to move
(cond
((and (equal (position-valid (- x 1) (+ y 0)) 'T) ;;up
(equal (position-valid (+ x 1) (+ y 0)) 'T));;down
(cond
((equal mov 'DOWN) (DOWN x y board))
((equal mov 'UP) (UP x y board))
(T (VERTICAL x y (1- n) mov board))))
(T NIL)))
and how to get the possible moves of the tower on the board based on the type of moves
Anny suggestion?
It seems to me that you are building too many functions which are unnecessary. What I would do is to have a MOVE function, based on move-piece, which would do both horizontal and vertical displacement. Since you have the parameter mov, which can be UP, DOWN, LEFT or RIGHT, the horizontal and vertical movements are already implicit, so there is no need to have a separate function for each direction.
So this is what I would do:
(setq board
'((64 35 74 26 21 57 12 28)
(43 15 47 53 24 56 42 29)
(51 41 71 31 17 45 55 30)
(67 66 22 T 54 75 32 38)
(13 11 16 23 25 27 33 20)
(34 36 37 44 46 52 61 48)
(10 49 59 69 68 70 50 40)
(62 63 65 72 73 76 77 58)))
(defun position-valid (x y)
(and (>= x 0) (>= y 0) (< x 8) (< y 8)) )
(defun move-piece (x y dx dy board)
(let ((new-board (copy-tree board))
(new-x (+ x dx))
(new-y (+ y dy))
(piece (nth x (nth y board))) )
(when (position-valid new-x new-y)
(setf (nth x (nth y new-board)) nil
(nth new-x (nth new-y new-board)) piece ))
new-board))
(defun MOVE (x y n mov board) ;; n is number of squares to move
(case mov
(UP (move-piece x y 0 (- n) board))
(DOWN (move-piece x y 0 n board))
(LEFT (move-piece x y (- n) 0 board))
(RIGHT (move-piece x y n 0 board))
(otherwise NIL) ))
And then, if you want to get a list of all possible moves:
(defun valid-moves (x y board)
(let (result)
(dolist (mov '(up down left right) result)
(dotimes (n 7)
(when (move x y n mov board)
(push (list n mov) result) )))))

inner and outer reduction, same result?

Does inner and outer reduction always create the same value, if not what would cause different ones?
I am talking about Racket, a functional language.
There are I know possibilities where it is more efficient like in Racket but actually causing a different result. I wasn't able to create a case where that happens, but I feel like it should be possible and may be. dangerous not to know.
Example:
;inner reduction
(sqr (* 3 (+ 1 (sqr 2))))
->(sqr (* 3 (+ 1 (* 2 2))) ;(sqr)
->(sqr (* 3 (+ 1 4)) ;(*)
->(sqr (* 3 5)) ;(+)
->(sqr 15) ;(*)
->(* 15 15) ;(sqr)
->225 ;(*)
;outer reduction
(sqr (* 3 (+ 1 (sqr 2))))
->(* (* 3 (+ 1 (sqr 2))) (* 3 (+ 1 (sqr 2))) ;(sqr)
->(* (* 3 (+ 1 (* 2 2))) (* 3 (+ 1 (sqr 2))) ;(sqr)
->(* (* 3 (+ 1 4)) (* 3 (+ 1 (sqr 2))) ;(*)
->(* (* 3 5) (* 3 (+ 1 (sqr 2))) ;(+)
->(* 15 (* 3 (+ 1 (sqr 2))) ;(*)
->(* 15 (* 3 (+ 1 (* 2 2))) ;(sqr)
->(* 15 (* 3 (+ 1 4))) ;(*)
->(* 15 (* 3 5)) ;(+)
->(* 15 15) ;(*)
->225 ;(*)
I don't know Racket, but in general you can run into trouble if any of your expressions have side effects, such as modifying variables, doing input/output, etc.
Take the following example:
(define x 1)
(sqr (begin (set! x (add1 x)) x))
Inner reduction:
; x = 1
(sqr (begin (set! x (add1 x)) x))
; x = 2
(sqr (begin x))
; x = 2
(sqr (begin 2))
; x = 2
(sqr 2)
; x = 2
(* 2 2)
; x = 2
4
I.e. the result is 4 and the final value of x is 2.
With outer reduction, you get:
; x = 1
(* (begin (set! x (add1 x)) x)
(begin (set! x (add1 x)) x))
; x = 2
(* (begin x)
(begin (set! x (add1 x)) x))
; x = 2
(* 2
(begin (set! x (add1 x)) x))
; x = 3
(* 2
(begin x))
; x = 3
(* 2
(begin x))
; x = 3
(* 2
3)
; x = 3
6
I.e. the result is 6 and the final value of x is 3.
There's another difference. With inner reduction it's possible that you don't get a result at all:
(define (my-if c t e)
(if c t e))
(define (loop)
(loop))
(my-if #t 42 (loop))
With outer reduction:
(my-if #t 42 (loop))
; definition of 'my-if'
(if #t 42 (loop))
; built-in 'if'
42
With inner reduction:
(my-if #t 42 (loop))
; definition of 'loop'
(my-if #t 42 (loop))
; definition of 'loop'
(my-if #t 42 (loop))
; definition of 'loop'
(my-if #t 42 (loop))
; definition of 'loop'
...
This never terminates.

Clisp compile error: "string" is not a real number

I'm new to lisp, so apologies if this question sounds pedantic:
I'm trying to build a Lisp program for a homework project that changes a series of Roman numbers into decimal numbers, using 1 function and just recursion. No variables, progn, assignments, or loops are allowed.
What I have so far is this:
(defun tonormal (inputs &optional (state 1) rostr)
(COND
((= state 1) (dolist (x inputs) (print (toroman nil 2 x))))
((= state 2) (COND
((equal (subseq rostr 0 1) "M" ) (+ 1000 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "CM") (+ 900 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "D" ) (+ 500 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "CD") (+ 400 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "C" ) (+ 100 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "XC") (+ 90 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "L" ) (+ 50 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "XL") (+ 40 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "X" ) (+ 10 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "IX") (+ 9 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "V" ) (+ 5 (toroman nil 2 (subseq rostr 1))))
((equal (subseq rostr 0 2) "IV") (+ 4 (toroman nil 2 (subseq rostr 2))))
((equal (subseq rostr 0 1) "I" ) (+ 1 (toroman nil 2 (subseq rostr 1))))
((= (length rostr) 0) (values))))))
When I try to call the function, I get this error message:
[191]> (tonormal '("MXXIV" "MMCMXX"))
*** - >=: "MXXIV" is not a real number
Is there any reason this damnable little error is popping up? If anyone could help, it'd be greatly appreciated. I've been working at it for hours.
I'm not sure what the state variable is supposed to be doing, but it's optional with a default value of 1, and since you're not passing a different value into (tonormal '("MXXIV" "MMCMXX")), it's triggering the first cond clause, meaning it's passing "MXXIV" into (toroman ...), which probably expects a numeric input.

A "pure" scheme implementation (R5RS) of SHA256?

I can use SHA256 in Scheme using external libraries (Java, C or system dependent) or using a specific Scheme implementation (like Chicken e.g.), but I wonder if there is a "pure" scheme implementation.
I wrote an implementation today. Alas, R5RS has neither bytevectors nor binary I/O, so this uses the R7RS APIs for bytevectors and binary I/O. It should be easy to bridge those APIs to your Scheme implementation's native APIs (for example, I actually tested my implementation on Racket and Guile).
A few notes:
This code assumes case-sensitivity. This is the default for R7RS, but not R5RS, so if you're using an R5RS implementation, beware.
It requires SRFIs 1, 26, 43, and 60.
I emphasise elegance and clarity over speed. In fact, the code is quite slow.
Contrary to what my profile says, I'm only licensing this code under the Apache Licence 2.0 (in addition to the standard Stack Overflow licence of CC BY-SA 3.0), and not under CC0 or anything resembling public domain.
Anyway, without further ado, here it is (also available as a Gist):
;;; Auxiliary definitions to avoid having to use giant tables of constants.
(define primes80 '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73
79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157
163 167 173 179 181 191 193 197 199 211 223 227 229 233 239
241 251 257 263 269 271 277 281 283 293 307 311 313 317 331
337 347 349 353 359 367 373 379 383 389 397 401 409))
(define (sqrt x)
(fold (lambda (_ y) (/ (+ (/ x y) y) 2)) 4 (iota 7)))
(define (cbrt x)
(fold (lambda (_ y) (/ (+ (/ x y y) y y) 3)) 4 (iota 8)))
(define (frac x scale base)
(bitwise-and (floor (* x (arithmetic-shift 1 scale)))
(- (arithmetic-shift 1 base) 1)))
;;; The actual initialisation and constant values.
(define sha1-init '(#x67452301 #xefcdab89 #x98badcfe #x10325476 #xc3d2e1f0))
(define sha2-init (map (lambda (x) (frac (sqrt x) 64 64)) (take primes80 16)))
(define-values (sha512-init sha384-init) (split-at sha2-init 8))
(define sha256-init (map (cut arithmetic-shift <> -32) sha512-init))
(define sha224-init (map (cut frac <> 0 32) sha384-init))
(define sha1-const (map (lambda (x) (frac (sqrt x) 30 32)) '(2 3 5 10)))
(define sha512-const (map (lambda (x) (frac (cbrt x) 64 64)) primes80))
(define sha256-const (map (cut arithmetic-shift <> -32) (take sha512-const 64)))
;;; Utility functions used by the compression and driver functions.
(define (u32+ . xs) (bitwise-and (apply + xs) #xffffffff))
(define (u64+ . xs) (bitwise-and (apply + xs) #xffffffffffffffff))
(define (bitwise-majority x y z)
(bitwise-xor (bitwise-and x y) (bitwise-and x z) (bitwise-and y z)))
(define (bytevector-be-ref bv base n)
(let loop ((res 0) (i 0))
(if (< i n)
(loop (+ (arithmetic-shift res 8) (bytevector-u8-ref bv (+ base i)))
(+ i 1))
res)))
(define (bytevector-u64-ref bv i)
(bytevector-be-ref bv (arithmetic-shift i 3) 8))
(define (bytevector-u32-ref bv i)
(bytevector-be-ref bv (arithmetic-shift i 2) 4))
(define (bytevector-be-set! bv base n val)
(let loop ((i n) (val val))
(when (positive? i)
(bytevector-u8-set! bv (+ base i -1) (bitwise-and val 255))
(loop (- i 1) (arithmetic-shift val -8)))))
(define (md-pad! bv offset count counter-size)
(define block-size (bytevector-length bv))
(unless (negative? offset)
(bytevector-u8-set! bv offset #x80))
(let loop ((i (+ offset 1)))
(when (< i block-size)
(bytevector-u8-set! bv i 0)
(loop (+ i 1))))
(when count
(bytevector-be-set! bv (- block-size counter-size) counter-size
(arithmetic-shift count 3))))
(define (hash-state->bytevector hs trunc word-size)
(define result (make-bytevector (* trunc word-size)))
(for-each (lambda (h i)
(bytevector-be-set! result i word-size h))
hs (iota trunc 0 word-size))
result)
;;; The compression functions.
(define (sha2-compress K Σ0 Σ1 σ0 σ1 mod+ getter hs)
(define W (vector->list (apply vector-unfold
(lambda (_ a b c d e f g h i j k l m n o p)
(values a b c d e f g h i j k l m n o p
(mod+ a (σ0 b) j (σ1 o))))
(length K)
(list-tabulate 16 getter))))
(define (loop k w a b c d e f g h)
(if (null? k)
(map mod+ hs (list a b c d e f g h))
(let ((T1 (mod+ h (Σ1 e) (bitwise-if e f g) (car k) (car w)))
(T2 (mod+ (Σ0 a) (bitwise-majority a b c))))
(loop (cdr k) (cdr w) (mod+ T1 T2) a b c (mod+ d T1) e f g))))
(apply loop K W hs))
(define (sha512-compress bv hs)
(define (rotr x y) (rotate-bit-field x (- y) 0 64))
(define (shr x y) (arithmetic-shift x (- y)))
(sha2-compress sha512-const
(lambda (x) (bitwise-xor (rotr x 28) (rotr x 34) (rotr x 39)))
(lambda (x) (bitwise-xor (rotr x 14) (rotr x 18) (rotr x 41)))
(lambda (x) (bitwise-xor (rotr x 1) (rotr x 8) (shr x 7)))
(lambda (x) (bitwise-xor (rotr x 19) (rotr x 61) (shr x 6)))
u64+ (cut bytevector-u64-ref bv <>) hs))
(define (sha256-compress bv hs)
(define (rotr x y) (rotate-bit-field x (- y) 0 32))
(define (shr x y) (arithmetic-shift x (- y)))
(sha2-compress sha256-const
(lambda (x) (bitwise-xor (rotr x 2) (rotr x 13) (rotr x 22)))
(lambda (x) (bitwise-xor (rotr x 6) (rotr x 11) (rotr x 25)))
(lambda (x) (bitwise-xor (rotr x 7) (rotr x 18) (shr x 3)))
(lambda (x) (bitwise-xor (rotr x 17) (rotr x 19) (shr x 10)))
u32+ (cut bytevector-u32-ref bv <>) hs))
(define (sha1-compress bv hs)
(define (getter x) (bytevector-u32-ref bv x))
(define (rotl x y) (rotate-bit-field x y 0 32))
(define W (vector->list (apply vector-unfold
(lambda (_ a b c d e f g h i j k l m n o p)
(values a b c d e f g h i j k l m n o p
(rotl (bitwise-xor a c i n) 1)))
80
(list-tabulate 16 getter))))
(define (outer f k w a b c d e)
(if (null? k)
(map u32+ hs (list a b c d e))
(let inner ((i 0) (w w) (a a) (b b) (c c) (d d) (e e))
(if (< i 20)
(let ((T (u32+ (rotl a 5) ((car f) b c d) e (car k) (car w))))
(inner (+ i 1) (cdr w) T a (rotl b 30) c d))
(outer (cdr f) (cdr k) w a b c d e)))))
(apply outer (list bitwise-if bitwise-xor bitwise-majority bitwise-xor)
sha1-const W hs))
;;; The Merkle-Damgård "driver" function.
(define (md-loop init compress block-size trunc word-size counter-size in)
(define leftover (- block-size counter-size))
(define bv (make-bytevector block-size))
(define pad! (cut md-pad! bv <> <> counter-size))
(define hs->bv (cut hash-state->bytevector <> trunc word-size))
(let loop ((count 0) (hs init))
(define read-size (read-bytevector! bv in))
(cond ((eof-object? read-size)
(pad! 0 count)
(hs->bv (compress bv hs)))
((= read-size block-size)
(loop (+ count read-size) (compress bv hs)))
((< read-size leftover)
(pad! read-size (+ count read-size))
(hs->bv (compress bv hs)))
(else
(pad! read-size #f)
(let ((pen (compress bv hs)))
(pad! -1 (+ count read-size))
(hs->bv (compress bv pen)))))))
;;; SHA-512/t stuff.
(define sha512/t-init (map (cut bitwise-xor <> #xa5a5a5a5a5a5a5a5) sha512-init))
(define (make-sha512/t-init t)
(define key (string->utf8 (string-append "SHA-512/" (number->string t))))
(define size (bytevector-length key))
(define bv (make-bytevector 128))
(bytevector-copy! bv 0 key)
(md-pad! bv size size 16)
(sha512-compress bv sha512/t-init))
(define (make-sha512/t t)
(define init (make-sha512/t-init t))
(define words (arithmetic-shift t -6))
(if (zero? (bitwise-and t 63))
(cut md-loop init sha512-compress 128 words 8 16 <>)
(lambda (in)
(bytevector-copy
(md-loop init sha512-compress 128 (ceiling words) 8 16 in)
0 (arithmetic-shift t -3)))))
;;; Public entry points.
(define sha1 (cut md-loop sha1-init sha1-compress 64 5 4 8 <>))
(define sha224 (cut md-loop sha224-init sha256-compress 64 7 4 8 <>))
(define sha256 (cut md-loop sha256-init sha256-compress 64 8 4 8 <>))
(define sha384 (cut md-loop sha384-init sha512-compress 128 6 8 16 <>))
(define sha512 (cut md-loop sha512-init sha512-compress 128 8 8 16 <>))
(define sha512/256 (make-sha512/t 256))
(define sha512/224 (make-sha512/t 224))
I implemented all the algorithms in FIPS 180-4, but you can strip out whatever you don't need.
As mentioned before, I tested this on Racket; the definitions I added to bridge to Racket's APIs are as follows:
#lang racket
(require (only-in srfi/1 iota)
(only-in srfi/26 cut)
(only-in srfi/43 vector-unfold)
(only-in srfi/60 bitwise-if rotate-bit-field)
(rename-in racket/base [build-list list-tabulate]
[bytes-copy! bytevector-copy!]
[bytes-length bytevector-length]
[bytes-ref bytevector-u8-ref]
[bytes-set! bytevector-u8-set!]
[foldl fold]
[make-bytes make-bytevector]
[read-bytes! read-bytevector!]
[string->bytes/utf-8 string->utf8]
[subbytes bytevector-copy]))
And here are the definitions for Guile (requires version 2.0.11 or above):
(use-modules (srfi srfi-1) (srfi srfi-26) (srfi srfi-43) (srfi srfi-60)
(rnrs bytevectors) (ice-9 binary-ports))
(define* (bytevector-copy bv #:optional (start 0) (end (bytevector-length bv)))
(define copy (make-bytevector (- end start)))
(bytevector-copy! copy 0 bv start end)
copy)
(define* (bytevector-copy! to at from #:optional (start 0)
(end (bytevector-length from)))
((# (rnrs bytevectors) bytevector-copy!) from start to at (- end start)))
(define* (read-bytevector! bv #:optional (port (current-input-port)) (start 0)
(end (bytevector-length bv)))
(get-bytevector-n! port bv start (- end start)))
It should be easy to make something similar for your chosen implementation.
I also have a function that prints out the output as a hex string, for ready comparison with various command-line SHA-1 and SHA-2 utilities (e.g., sha1sum, sha256sum, sha512sum, etc.):
(define (hex bv)
(define out (open-output-string))
(do ((i 0 (+ i 1)))
((>= i (bytevector-length bv)) (get-output-string out))
(let-values (((q r) (truncate/ (bytevector-u8-ref bv i) 16)))
(display (number->string q 16) out)
(display (number->string r 16) out))))

How to print a list as matrix in Common Lisp

I am working in Common Lisp, trying to make Windows game minesweeper.
I have a list (1 1 1 2 2 2 3 3 3) and want to print that like matrix
(1 1 1
2 2 2
3 3 3)
How to do that?
Edit
I am at the beginning of
(format t "Input width:")
(setf width (read))
(format t "Input height:")
(setf height (read))
(format t "How many mines:")
(setf brMina (read))
(defun matrica (i j)
(cond ((= 0 i) '())
(t (append (vrsta j) (matrica (1- i) j) ))))
(setf minefield (matrica width height))
(defun stampaj ()
(format t "~%~a" minefield ))
Another example, using the pretty-printer for fun:
(defun print-list-as-matrix
(list elements-per-row
&optional (cell-width (1+ (truncate (log (apply #'max list) 10)))))
(let ((*print-right-margin* (* elements-per-row (1+ cell-width)))
(*print-miser-width* nil)
(*print-pretty* t)
(format-string (format nil "~~<~~#{~~~ad~~^ ~~}~~#:>~%" cell-width)))
(format t format-string list)))
Works like this:
CL-USER> (print-list-as-matrix (loop for i from 1 to 9 collect i) 3)
1 2 3
4 5 6
7 8 9
NIL
CL-USER> (print-list-as-matrix (loop for i from 1 to 25 collect i) 5)
1 2 3 4 5
6 7 8 9 10
11 12 13 14 15
16 17 18 19 20
21 22 23 24 25
NIL
CL-USER> (print-list-as-matrix (loop for i from 1 to 16 collect i) 2)
1 2
3 4
5 6
7 8
9 10
11 12
13 14
15 16
Like this:
(defun print-list-as-grid (list rows cols)
(assert (= (length list) (* rows cols))
(loop for row from 0 below rows do
(loop for col from 0 below cols do
(princ (car list))
(princ #\space)
(setf list (cdr list)))
(princ #\newline)))
* (print-list-as-grid '(a b c d e f g h i) 3 3)
A B C
D E F
G H I
NIL