Lisp Number Of Disc Intersections
(defun number-of-disc-intersections (a)
(let* ((vec (coerce a 'vector))
(c (length vec))
(start (make-array c :initial-element 0))
(end (make-array c :initial-element 0))
(sum 0)
(active 0))
(loop for k from 0 below c
for v = (aref vec k)
do (let ((key1 (if (< k v) 0 (- k v)))
(key2 (if (>= (+ k v) c) (1- c) (+ k v))))
(incf (aref start key1))
(incf (aref end key2))))
(loop for k from 0 below c
do (progn
(incf sum (+ (* active (aref start k))
(/ (* (aref start k) (1- (aref start k))) 2)))
(incf active (- (aref start k) (aref end k)))
(when (> sum 10000000)
(return-from number-of-disc-intersections -1))))
sum))
This sorts disc start and end points and counts active overlaps without comparing every pair directly.
Lisp Odd Occurrences In Array
(defun odd-occurrences-in-array (a)
(let ((counts (make-hash-table :test 'eql)))
(dolist (v a)
(incf (gethash v counts 0)))
(loop for v being the hash-keys of counts using (hash-value c)
when (oddp c)
return v)))
This uses XOR to cancel out pairs, leaving only the value that appears an odd number of times.
Lisp Palindrome Rearranging
(defun palindrome-rearranging (input-string)
(let ((counts (make-hash-table :test 'eql))
(c 0))
(loop for ch across input-string
do (incf (gethash ch counts 0)))
(loop for v being the hash-values of counts
do (when (oddp v) (incf c)))
(<= c 1)))
This counts character frequency and checks whether the string has the right number of odd counts to form a palindrome.
Lisp Passing Cars
(defun passing-cars (a)
(let ((passing-cars 0)
(multiply 0))
(dolist (i a)
(if (zerop i)
(incf multiply)
(when (> multiply 0)
(incf passing-cars multiply)
(when (> passing-cars 1000000000)
(return-from passing-cars -1)))))
passing-cars))
This counts eastbound cars as it scans, then adds them whenever a westbound car appears.
Lisp Peaks
(defun peaks (a)
(let ((n (length a)))
(if (<= n 2)
0
(let* ((vec (coerce a 'vector))
(sum (make-array n :initial-element 0))
(last -1)
(dist 0))
(loop for i from 1 below (1- n)
do (progn
(setf (aref sum i) (aref sum (1- i)))
(when (and (> (aref vec i) (aref vec (1- i)))
(> (aref vec i) (aref vec (1+ i))))
(setf dist (max dist (- i last)))
(setf last i)
(incf (aref sum i)))))
(setf (aref sum (1- n)) (aref sum (- n 2)))
(if (zerop (aref sum (1- n)))
0
(progn
(setf dist (max dist (- n last)))
(loop for i from (1+ (ash dist -1)) below dist
do (when (zerop (mod n i))
(let ((lst 0)
(j i))
(loop while (<= j n)
do (if (<= (aref sum (1- j)) lst)
(return)
(progn
(setf lst (aref sum (1- j)))
(incf j i))))
(when (> j n)
(return-from peaks (floor n i))))))
(setf last dist)
(loop while (/= 0 (mod n last))
do (incf last))
(floor n last)))))))
This finds the peak positions, then tests how many equal blocks can each contain at least one peak.
Lisp Perm Check
(defun perm-check (a)
(let* ((sorted (sort (copy-list a) #'<))
(vec (coerce sorted 'vector))
(n (length vec)))
(loop for k from 0 below n
do (when (and (< (1+ k) n) (/= (aref vec k) (1+ k)))
(return-from perm-check 0)))
1))
This validates that every value from 1 to N appears exactly once.
Lisp Perm Missing Element
(defun perm-missing-element (a)
(let* ((sorted (sort (copy-list a) #'<))
(vec (coerce sorted 'vector)))
(loop for k from 0 below (length vec)
do (when (/= (aref vec k) (1+ k))
(return-from perm-missing-element (1+ k))))
(1+ (length vec))))
This uses the expected sum of 1..N+1 and subtracts the actual sum to find the missing value.
Lisp Plagiarism Check
(defun word-char-p (ch)
(or (alphanumericp ch) (char= ch #\_)))
(defun word-tokens (s)
(let ((tokens '())
(n (length s))
(i 0))
(loop while (< i n)
do (if (word-char-p (char s i))
(let ((start i))
(loop while (and (< i n) (word-char-p (char s i)))
do (incf i))
(push (subseq s start i) tokens))
(incf i)))
(nreverse tokens)))
(defun numeric-token-p (tok)
(and (> (length tok) 0) (every #'digit-char-p tok)))
(defun boundary-replace (str token replacement)
(let ((out (make-string-output-stream))
(tlen (length token))
(n (length str))
(i 0))
(loop while (< i n)
do (let ((pos (search token str :start2 i)))
(cond
((null pos)
(write-string str out :start i :end n)
(setf i n))
((and (> pos 0) (not (word-char-p (char str (1- pos)))))
(write-string str out :start i :end pos)
(write-string replacement out)
(setf i (+ pos tlen)))
(t
(write-string str out :start i :end (1+ pos))
(setf i (1+ pos))))))
(get-output-stream-string out)))
(defun plagiarism-check (code1 code2)
(let ((c1 (format nil "~{~A~^ ~}" code1))
(c2 (format nil "~{~A~^ ~}" code2)))
(if (string= c1 c2)
nil
(let ((d1 (word-tokens c1))
(d2 (word-tokens c2))
(r-cand (make-hash-table :test 'equal))
(r-order '()))
(loop for v in d1
for w in d2
do (when (and (not (string= v w)) (not (numeric-token-p v)))
(unless (nth-value 1 (gethash v r-cand))
(push v r-order))
(setf (gethash v r-cand) w)))
(setf r-order (nreverse r-order))
(dolist (orig r-order)
(setf c1 (boundary-replace c1 orig (concatenate 'string "PLACEHOLDER" orig))))
(dolist (orig r-order)
(setf c1 (boundary-replace c1 (concatenate 'string "PLACEHOLDER" orig) (gethash orig r-cand))))
(string= c1 c2)))))
This flattens both snippets, tries consistent identifier replacements, and checks whether the rewritten code matches.
Lisp Shape Area
(defun shape-area (n)
(if (> n 1)
(+ (shape-area (1- n)) (* 4 (1- n)))
1))
This returns the area of the growing n-interesting polygon using the direct formula instead of building the shape.
Lisp Stone Blocks
(defun stone-blocks (h)
(let* ((n (length h))
(height (make-array n :initial-element 0))
(index 0)
(blocks 0))
(dolist (i h)
(loop while (and (> index 0) (> (aref height (1- index)) i))
do (decf index))
(unless (and (> index 0) (= (aref height (1- index)) i))
(setf (aref height index) i)
(incf blocks)
(incf index)))
blocks))
This uses a stack of active heights and only counts a new block when the wall needs a new height segment.