gistfile1.lisp

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (ext:package-lock :ext) nil))


(defun non-alphanumericp (ch)
  (not (alphanumericp ch)))

(defvar +hex-chars+ "0123456789ABCDEF")
(declaim (type simple-string +hex-chars+))

(defun hexchar (n)
  (declare (type (integer 0 15) n))
  (schar +hex-chars+ n))

(defun count-string-char (s c)
  "Return a count of the number of times a character appears in a string"
  (declare (simple-string s)
       (character c)
       (optimize (speed 3) (safety 0)))
  (do ((len (length s))
       (i 0 (1+ i))
       (count 0))
      ((= i len) count)
    (declare (fixnum i len count))
    (when (char= (schar s i) c)
      (incf count))))


(defun count-string-char-if (pred s)
  "Return a count of the number of times a predicate is true
for characters in a string"
  (declare (simple-string s)
       (type (or function symbol) pred)
       (optimize (speed 3) (safety 0) (space 0)))
  (do ((len (length s))
       (i 0 (1+ i))
       (count 0))
      ((= i len) count)
    (declare (fixnum i len count))
    (when (funcall pred (schar s i))
      (incf count))))

(defconstant +char-code-lower-a+ (char-code #\a))
(defconstant +char-code-upper-a+ (char-code #\A))
(defconstant +char-code-0+ (char-code #\0))
(declaim (type fixnum +char-code-0+ +char-code-upper-a+
           +char-code-0))

(defun charhex (ch)
  "convert hex character to decimal"
  (let ((code (char-code (char-upcase ch))))
    (declare (fixnum ch)) 
    (if (>= code +char-code-upper-a+)
    (+ 10 (- code +char-code-upper-a+))
    (- code +char-code-0+))))

(defun uriencode-string (query)
  "Escape non-alphanumeric characters for URI fields"
  (declare (simple-string query)
       (optimize (speed 3) (safety 0) (space 0)))
  (do* ((count (count-string-char-if #'non-alphanumericp query))
    (len (length query))
    (new-len (+ len (* 2 count)))
    (str (make-string new-len))
    (spos 0 (1+ spos))
    (dpos 0 (1+ dpos)))
      ((= spos len) str)
    (declare (fixnum count len new-len spos dpos)
         (simple-string str))
    (let ((ch (schar query spos)))
      (if (non-alphanumericp ch)
      (let ((c (char-code ch)))
        (setf (schar str dpos) #\%)
        (incf dpos)
        (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
        (incf dpos)
        (setf (schar str dpos) (hexchar (logand c 15))))
    (setf (schar str dpos) ch)))))

(defun uridecode-string (query)
  "Unescape non-alphanumeric characters for URI fields"
  (declare (simple-string query)
       (optimize (speed 3) (safety 0) (space 0)))
  (do* ((count (count-string-char query #\%))
    (len (length query))
    (new-len (- len (* 2 count)))
    (str (make-string new-len))
    (spos 0 (1+ spos))
    (dpos 0 (1+ dpos)))
      ((= spos len) str)
    (declare (fixnum count len new-len spos dpos)
         (simple-string str))
    (let ((ch (schar query spos)))
      (if (char= #\% ch)
      (let ((c1 (charhex (schar query (1+ spos))))
        (c2 (charhex (schar query (+ spos 2)))))
        (declare (fixnum c1 c2))
        (setf (schar str dpos)
          (code-char (logior c2 (ash c1 4))))
        (incf spos 2))
    (setf (schar str dpos) ch)))))

(defun current-time (&optional (out t))
  "Print the current time to the stream (defaults to T)."
  (multiple-value-bind (se mi ho da mo ye) (get-decoded-time)
    (format out "~4d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
            ye mo da ho mi se)))

(defmacro string-beg-with (beg strv &optional (lenv `(length ,strv)))
  "Check whether the string STRV starts with BEG."
  (if (stringp beg)
      (let ((len (length beg)))
        `(and (>= ,lenv ,len) (string-equal ,beg ,strv :end2 ,len)))
      (with-gensyms ("SBW-" len)
        `(let ((,len (length ,beg)))
          (and (>= ,lenv ,len) (string-equal ,beg ,strv :end2 ,len))))))

;; The characters which must be replaced before putting a string into HTML
(defvar *html-chars* '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;")))

(clos:defclass html-stream-out (fundamental-character-output-stream)
  ((target-stream :initarg :stream :type stream)))
(clos:defmethod stream-write-char ((stream html-stream-out) ch)
  (clos:with-slots (target-stream) stream
    (let ((char-cons (assoc ch *html-chars* :test #'char=)))
      (if char-cons (write-string (cdr char-cons) target-stream)
          (write-char ch target-stream)))))
(clos:defmethod stream-line-column ((stream html-stream-out)) nil)
(clos:defmethod stream-finish-output ((stream html-stream-out))
  (clos:with-slots (target-stream) stream (finish-output target-stream)))
(clos:defmethod stream-force-output ((stream html-stream-out))
  (clos:with-slots (target-stream) stream (force-output target-stream)))
(clos:defmethod stream-clear-output ((stream html-stream-out))
  (clos:with-slots (target-stream) stream (clear-output target-stream)))
(clos:defmethod close ((stream html-stream-out) &rest opts)
  (clos:with-slots (target-stream) stream (apply #'close target-stream opts))
  (call-next-method))


(defvar *with-html-output-doctype*
  '("html" "PUBLIC" "\"-//W3C//DTD XHTML 1.0 Strict//EN\""
    "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\""))

(defvar *user-mail-address*
  (concatenate 'string (or (getenv "USER") (getenv "USERNAME") "nobody") "@"
               (let ((st (machine-instance)))
                 (subseq st 0 (position #\Space st)))))

(defmacro with-html-output ((var stream
                             &key (doctype '*with-html-output-doctype*)
                                  (meta '(:http-equiv "Content-Type"
                                          :content "text/html"))
                                  base comment (title "untitled") (footer t)
                                  head)
                            &body body)
  (with-gensyms ("HTML-" raw mailto)
    `(let* ((,raw ,stream)
            (,var (clos::make-instance 'html-stream-out :stream ,raw))
            (,mailto (concatenate 'string "mailto:" *user-mail-address*)))
      (macrolet ((with-tag ((tag &rest options) &body forms)
                   `(progn (format ,',raw "<~a~@{ ~a=~s~}>" ,tag ,@options)
                     ,@forms (format ,',raw "</~a>~%" ,tag)))
                 (with-tagl ((tag &rest options) &body forms)
                   `(progn (format ,',raw "<~a~@{ ~a=~s~}>" ,tag ,@options)
                     ,@forms (format ,',raw "</~a>" ,tag))))
        (unwind-protect
             (progn
               (format ,raw "<!DOCTYPE~{ ~a~}>~%" ,doctype)
               ;; print the comment
               (format ,raw "<!--~% Created on ") (current-time ,raw)
               (format ,raw "~% by ~a~% using `with-open-html'
 Lisp: ~a ~a~@[~%~a~]~% -->~2%"
                       *user-mail-address*
                       (lisp-implementation-type) (lisp-implementation-version)
                       ,comment)
               (when ,base
                 (with-tag (:base :href ,base)))
               (with-tag (:html)
                 (with-tag (:head ,@head)
                   (with-tag (:meta ,@meta))
                   (with-tag (:meta :http-equiv "Pragma" :content "no-cache" ))
                   (with-tag (:link :rev "made" :href ,mailto))
                   (with-tag (:title) (princ ,title ,var)))
                 (with-tag (:body)
                   ,@body
                   (when ,footer
                     (with-tag (:p)
                       (with-tag (:hr))
                       (with-tag (:address)
                         (with-tag (:a :href ,mailto)
                           (princ *user-mail-address* ,var)))
                       (with-tagl (:strong) (current-time ,var)))))))
          (when ,var (close ,var))
          #+nil(when ,raw (close ,raw)))))))

(defvar *http-encoding*
  (make-encoding #+UNICODE :charset #+UNICODE charset:utf-8
                 :line-terminator :dos))

(defmacro with-http-output ((var raw &rest opts &key keep-alive (debug 1)
                             (return-code 200) (return-name "OK")
                             &allow-other-keys)
                            &body body)
  "Write some HTML to an http client on socket stream RAW.
Supplies some HTTP/1.0 headers and calls `with-html-output'."
  (with-gensyms ("HTTP-" string vector stream sock header line dbg alive)
    `(let* ((,sock ,raw)
            (,dbg ,debug) (,alive ,keep-alive)
            (,string (with-output-to-string (,stream)
                       (with-html-output (,var ,stream ,@(remove-plist opts :keep-alive :debug :return-code :return-name))
                         ,@body)))
            (,vector (ext:convert-string-to-bytes ,string *http-encoding*))
            (,header (list (format nil "HTTP/1.0 ~d ~a"
                                   ,return-code ,return-name)
                           #+UNICODE "Content-type: text/html; charset=utf-8"
                           #-UNICODE "Content-type: text/html"
                           (format nil "Content-length: ~d" (length ,vector))
                           (format nil "Connection: close"))))
       (dolist (,line ,header)
         (write-line ,line ,sock)
         (when (and ,dbg (> ,dbg 0))
           (format t "<- ~a~%" ,line)))
       (terpri ,sock)
       (setf (stream-element-type ,sock) 'unsigned-byte)
       (write-byte-sequence ,vector ,sock)
       (setf (stream-element-type ,sock) 'character)
       (when (and ,dbg (> ,dbg 3))
       (close ,sock)))))

(defun flush-http (sock)
  "Read everything from the HTTP socket SOCK, until a blank line."
  (loop :for line = (read-line sock nil nil)
        :while (and line (plusp (length line)))
        :collect line))

(defun http-error (sock url &key (name "Not Found") (code 404)
                   (keep-alive nil) (debug 0))
  "Report a request error."
  (with-http-output (out sock :keep-alive keep-alive :debug debug
                          :return-code code :return-name name)
    (with-tag (:h1) (princ name out))
    (with-tag (:p)
      (format out "The requested URL ~s was not found on this server." url))))


(defparameter *debuglevel* 0)

(defun http-command (server &key (debug 5) socket)
  "Accept a connection from the server, return the GET command and the socket."
  (when (> debug 1)
    (format t "~s: server: ~s; socket: ~s~%" 'http-command server socket))
  (let (response id com keep-alive)
    (loop (unless (and socket (open-stream-p socket))
            (setq socket (socket-accept server
                                        :external-format *http-encoding*))
            (when (> debug 1)
              (format t "~s: new socket: ~s~%" 'http-command socket)))
          (setq response (flush-http socket))
          (when response (return))
          ;; connection timed out?
          (close socket))
    (when (> debug 1)
      (dolist (line response)
        (format t "-> ~a~%" line)))
    (dolist (line response)
      (when (string-beg-with "Connection: " line)
        (setq keep-alive (string-equal line "keep-alive" :start1 12))
        (when (> debug 0)
          (format t "~s: connection: ~s (keep-alive: ~s)~%"
                  'http-command (subseq line 12) keep-alive))
        (when keep-alive
          ;; we override `keep-alive' because it makes it impossible to
          ;; switch browsers in the middle of an inspection session
          (setq keep-alive nil)
          (when (> debug 0)
            (format t "~s: overriding keep-alive to NIL~%" 'http-command))))
      (when (string-beg-with "GET /" line)
        (let ((pos (position #\/ line :test #'char= :start 5)))
          (setq id (parse-integer line :start 5 :end pos :junk-allowed t))
          (cond (id
                 (setq com (read-from-string 
                    (uridecode-string (subseq line (1+ pos))) nil nil))
                 (when (> debug 0)
                   (format t "~s: command: id=~d com=~s~%"
                           'http-command id com)))
                (t
                 (http-error socket line :debug debug :keep-alive keep-alive)
                 (when (> debug 0)
                   (format t "~s: invalid request: ~s~%"
                           'http-command line)))))))
    (values socket id com keep-alive)))

(defvar make-url nil)

(defmacro render-field ()
  `(with-tag (:table)
	    (loop for y from 0
	      and row in *field*
	      do (with-tag (:tr)
			   (loop for x from 0
			     and cell in row
			     do (with-tag (:td)
					  (case cell
					    (0 (with-tag (:a :href (make-url (list :hit x y))) (princ "_" out)))
					    (:X (princ "X" out))
					    (:O (princ "O" out)))))))))


(defun serverloop ()
  (do ((server
        (let* ((server (socket-server)) (port (socket-server-port server))
               (host (machine-instance)))
          (when (> *debuglevel* 0)
            (format t "~&~s [~s]: server: ~s~%"
                    'inspect-frontend frontend server))
	  (setf (symbol-function 'make-url) (lambda (cmd) (format nil "http://~a:~d/0/~s"
					       (if *inspect-browser* "127.0.0.1"
						 (subseq host 0 (position #\Space host)))
					       port cmd)))
          (browse-url (format nil "http://~a:~d/0/:s"
                              (if *inspect-browser* "127.0.0.1"
                                  (subseq host 0 (position #\Space host)))
                              port)
                      :browser *inspect-browser*)
          server))
       sock id com keep-alive)
      ((eq com :q) (socket-server-close server)
       (when (open-stream-p sock)
         (do () ((null (read-char-no-hang sock))))
         (close sock)))
    (setf (values sock id com keep-alive) (http-command server :socket sock))
    (print (list sock id com keep-alive))
    (when com
	    (case com
    	  (:q (with-http-output (out sock :keep-alive keep-alive
				       :debug *debuglevel*
			    	   :title "end" :footer nil)			  
				  (with-tag (:p) (princ "you may close this window now" out))))
	      (:s (do-start-session sock))
    	  (t (process-command sock com))))))
          
(defvar *field* nil)


(defun make-fresh-field (xdim ydim)
    (loop repeat ydim collect
      (loop repeat xdim collect 0)))
                                
(defun do-start-session(sock)
  (setq *field* (make-fresh-field 15 15))
  (with-http-output (out sock :keep-alive t
			 :debug *debuglevel*
			 :title "start" :footer nil)
		    (with-tag (:h1) (princ "starting new game" out))
		    (render-field)))

	      

(defvar *X* :X)
(defvar *O* :O)

(defun process-command (sock cmd )
  (with-http-output (out sock :keep-alive t
			 :debug *debuglevel*
			 :title "XO" :footer nil)
		    (if (listp cmd)
			(case (first cmd)
			  (:HIT
			   (destructuring-bind (op x y) cmd
					      (setf (nth x (nth y *field*)) *X*)
					      (let ((msg (make-move)))
						(when msg
						  (princ msg out))))
			   )))
		    (render-field)))


;; Here are the scores of the nine "non-polluted" configurations.  Tuning
;; these values will change (hopefully improve) the strength of the program
;; and may change its style (rather aggressive here).

(defconstant nil-score   7  "Score of an empty qtuple.")
(defconstant Xscore     15  "Score of a qtuple containing one X.")
(defconstant XXscore   400  "Score of a qtuple containing two X's.")
(defconstant XXXscore     1800  "Score of a qtuple containing three X's.")
(defconstant XXXXscore  100000  "Score of a qtuple containing four X's.")
(defconstant Oscore     35  "Score of a qtuple containing one O.")
(defconstant OOscore   800  "Score of a qtuple containing two O's.")
(defconstant OOOscore    15000  "Score of a qtuple containing three O's.")
(defconstant OOOOscore  800000  "Score of a qtuple containing four O's.")

;; As we choosed values 0, 1 and 6 to denote empty, X and O squares, the
;; contents of a qtuple is uniquely determined by the sum of its elements and
;; we just have to set up a translation table.

(defconstant gomoku-score-trans-table
  (vector nil-score Xscore XXscore XXXscore XXXXscore 0
      Oscore    0      0       0        0         0
      OOscore   0      0       0        0         0
      OOOscore  0      0       0        0         0
      OOOOscore 0      0       0        0         0
      0)
  "Vector associating qtuple contents to their score.")

(defconstant +field-y+ 15)
(defconstant +field-x+ 15)

(defun get-score-in-direction (x y dx dy)
  (if (and (<= 0 (+ x (* 4 dx)) (1- +field-x+))
	   (<= 0 (+ y (* 4 dy)) (1- +field-y+)))
      (let ((sm (loop repeat 5
		   for xd from x by dx
		   for yd from y by dy
		   sum (let ((cell (nth xd (nth yd *field*))))
			 (cond
			  ((eql cell 0) 0)
			  ((eql cell *X*) 6)
			  ((eql cell *O*) 1))))))
	(aref gomoku-score-trans-table sm))
    0))

(defun get-score-for (x y)
  (loop repeat 5
    for leftb from x downto 0
    for highb downfrom y
    for lowb upfrom y
    when (>= highb 0) sum (get-score-in-direction leftb highb +1 +1)
    when (>= highb 0) sum (get-score-in-direction x highb 0 +1)
    when (< lowb +field-y+) sum (get-score-in-direction leftb lowb +1 -1)
    sum (get-score-in-direction leftb y +1 0)))

(defun get-best-score (test)
  (let ((best-score 0)
	best-coords)
    (dotimes (x +field-x+)
      (dotimes (y +field-y+)
	(when (eql (nth x (nth y *field*)) 0)
	  (let ((score (get-score-for x y)))
	    (cond
	     ((= best-score score) (push (cons x y) best-coords))
	     ((funcall test best-score score)
	      (setq best-coords (list (cons x y))
		    best-score score)))))))
    best-coords))
	
    
(defun make-move ()
  (let ((pairs (get-best-score #'<)))
    (if pairs
	(let ((move (nth (random (length pairs)) pairs)))
	  (setf (nth (car move) (nth (cdr move) *field*)) *O*)
	  nil)
      "no more moves")))