Common LISP

Une macro dans Common Lisp est une vraie macro, entendons par là que le compilateur gén`ere le code qu’on lui demande de générer sans se poser de questions:

(defmacro print-random (i) 
                 `(let ((rr (random 10))) 
                       (format t "~A~%" (+ ,i rr))))

En plus d’être inutile, ce code en Common Lisp n’est pas correct, la variable rr peut être en conflit avec une autre variable dans contexte lexical ou cette macro est appelée. Une version correcte serait:

(defmacro print-random (i) 
                  (let ((rr (gensym))) 
                      `(let ((,rr (random 10))) 
                            (format t "~A~%" (+ ,i ,rr)))))

Ici, la variable rr est déclarée dans un champ lexical et associé à un nom unique généré par (gensym), elle est utilisée ensuite de la même façon que n’importe quelle variable passée en argument à la macro. Dans les faits, les deux versions de la macro vont fonctionner très bien, mais seule la seconde assure qu’il n’y aura pas d’effets secondaires.

Clojure est beaucoup plus stricte, il n’accepte pas l’utilisation de variables non déclarées dans ses macro et rend obligatoire l’utilisation de (gensym) dans un tel contexte. Ce qui peut poser problème lorsqu’on veut imbriquer deux macros qui utilisent la même variable.

Afin de simplifier l’utilisation de JDBC, je souhaite déclarer une macro (with-db & body) dans la quelle se trouve un environnement lexical qui me permette d’accéder directement à la base de données avec d’autres macros (fetch-db request) et (exec-db request).

(with-db (fetch-db ["select now()"]))

Le problème étant que le (with-open) utilisé par JDBC génère une variable lexicale qu’il faut reprendre dans les arguments de (jdbc/fetch) ou (jdbc/execute).

C’est ici qu’intervient le principe de LOM, ou Let Over Macro:

(let [cn (gensym)]
  (defmacro with-db [& body]
    `(with-open [~cn (jdbc/connection db)]
       ~@body))

  (defmacro exec-db [request]
    `(jdbc/execute ~cn ~request))

  (defmacro fetch-db [request]
    `(jdbc/fetch ~cn ~request)))

Le (let …) au lieu de se trouver à l’intérieur de la macro se trouve à l’extérieur, afin de créer un environnement lexical auquel toutes les macros peuvent accéder.

Un neurone est une fonction extrêmement simple qui prend un certain nombre de paramètres et retourne soit 0 (ou -1) soit 1 selon la valeur des arguments qui lui sont passés. Il multiplie chacun de ces argument par une valeur, additionne le tout et rajoute une constante. Si le résultat de cette opération est positive, alors il retourne 1, si elle est négative, il retourne -1.

L’intérêt de ce neurone, c’est qu’il est capable d’apprendre, c’est à dire que si on lui montre un jeu de données avec le résultat attendu, il va régler de lui même les constantes à utiliser pour sa petite opération et essayer de trouver une valeur idéale pour retourner la bonne réponse.

Ça vous intéresse, je vous suggère la lecture de la page Wikipedia et de faire vos propres recherches : https://en.wikipedia.org/wiki/Perceptron

Mon implémentation est sans doute très naïve et je suis certain qu’il existe une tonne de librairies qui le font beaucoup mieux que moi. Mais l’objectif ici est de comprendre le rouage de la chose, comment cela fonctionne. Une fois cela compris, il est certain que se tourner vers une librairie, complète, testée et optimisée est tout à fait recommandable pour faire un vrai projet en prod.

(setf data '(
	     (20 2000 1)
	     (40 1000 -1)
	     (30 3000 1)
	     (30 1000 -1)
	     (20 3000 1)
	     (40 2000 -1)
	     (40 4000 1)
	     (20 2000 -1)
	     (30 4000 1)
	     (20 4000 1)
	     (40 3000 -1)))


(defvar w '(1 1 1))

(defun magic (w x y)
  (if (> (+ (first w) (* (second w) x) (* (third w) y)) 0)
      1
      -1))


(dolist (l data)
  (format t "-----~%")
  (format t "~A~%" l)
  (let ((c (magic w (first l) (second l)))
	(alpha 0.00001))
    (format t "G/S=> ~A/~A~%" c (third l))
    
    (setf (first w)
	  (+ (first w) (*
			1
			alpha
			(- (third l) c))))
    (setf (second w)
	  (+ (second w) (*
			 (first l)
			 alpha
			 (- (third l) c ))))
    (setf (third w)
	  (+ (third w) (*
			(second l)
			alpha
			(- (third l) c))))
    (format t "~A~%" w)))
  
  
	     
      

Je n’ai pas la moindre idée de comment se nomme ce jeu en Français, il s’agit de cette grille de trois sur trois ou l’on rentre des X et des O. Le premier à avoir aligné trois caractères identique a gagné la partie.

Dans ma course à la compréhension de l’Intelligence artificielle, j’ai donc décidé de m’attaquer `a ce jeu et d’implanter l’algorithme Minimax en Common Lisp.

L’ordinateur n’est pas imbattable, en fait, il suffit d’un peu de stratégie pour gagner, mais il tient quand même la partie. Je pense qu’il faudrait pondérer les coups en fonction du nombre de coups avant de gagner pour améliorer le système. Mais qu’à cela ne tienne, l’ordinateur connait les règles, il essaye de gagner et essaye de faire perdre son adversaire.

Le principle consiste tout simplement à visualiser par avance toutes les parties possibles pour chaque coup et de jouer en priorité ceux qui lui permettent d’arriver à la victoire.

Le code ci-dessous:

#!/opt/homebrew/bin/sbcl --script


(defmacro t-equal (p a b c)
  `(and
    (equal ,p ,a)
    (equal ,a ,b)
    (equal ,a ,c)))

(defun arrived (player state)
  (or
   (t-equal player (nth 0 state) (nth 1 state) (nth 2 state))
   (t-equal player (nth 3 state) (nth 4 state) (nth 5 state))
   (t-equal player (nth 6 state) (nth 7 state) (nth 8 state))
   (t-equal player (nth 0 state) (nth 4 state) (nth 8 state))
   (t-equal player (nth 2 state) (nth 4 state) (nth 6 state))
   (t-equal player (nth 0 state) (nth 3 state) (nth 6 state))
   (t-equal player (nth 1 state) (nth 4 state) (nth 7 state))
   (t-equal player (nth 2 state) (nth 5 state) (nth 8 state))))

(defun actions (state player)
  (let ((ret ()))
    (dotimes (i 9)
      (when (null (nth i state))
	(let ((node (copy-list state)))
	  (setf (nth i node) player)
	  (push node ret))))
    ret))

(defun display-board (state)
  (format t "--~%~%~A|~A|~A~%-----~%~A|~A|~A~%-----~%~A|~A|~A~%"
	  (or (nth 0 state) " ")
	  (or (nth 1 state) " ")
	  (or (nth 2 state) " ")
	  (or (nth 3 state) " ")
	  (or (nth 4 state) " ")
	  (or (nth 5 state) " ")
	  (or (nth 6 state) " ")
	  (or (nth 7 state) " ")
	  (or (nth 8 state) " ")))

(defun other-player (player)
  (if (equal player 1)
      2
      1))

(defun utility (state)
  (when (arrived 1 state)
    (return-from utility -1))
  (when (arrived 2 state)
    (return-from utility 1))
  0)

(defun arrived? (state)
  (or
   (arrived 1 state)
   (arrived 2 state)))

(defun max-value (state)
  (when (arrived? state)
    (return-from max-value (utility state)))
  (let ((actions (actions state 2))
	(l '(-99999999999)))
    (dolist (action actions)
      (push (min-value action) l))
    (reduce #'max l)))

(defun min-value (state)
  (when (arrived? state)
    (return-from min-value (utility state)))
  (let ((actions (actions state 1))
	(l '(9999999999)))
    (dolist (action actions)
      (push (max-value action) l))
    (reduce #'min l)))



(defun ask-user (state)
  (display-board state)
  (format t "From 0 to 8, where do you play ?~%")
  (let ((input (read)))
    (setf (nth input state) 1))
  state)

(defvar state '(nil nil nil nil nil nil nil nil nil))

(loop
  (when (arrived? state)
    (display-board state)
    (format t "Computer wins~%")
    (return))
  (setf state (ask-user state))
  (when (arrived? state)
    (display-board state)
    (format t "User wins~%")
    (return))
  
  (let ((actions (actions state 2))
	(temporary-state nil)
	(v -9999))
    (dolist (action actions)
      (let ((w (min-value action)))
	(when (> w v)
	  (display-board action)
	  (format t "Got ~A~%" w)
	  (setf v w)
	  (setf temporary-state action))))
    (setf state temporary-state)))


    

     
  

Me voici lancé dans les cours d’Intelligence Artificielles de Harvard. Le court entier de Brian Yu sont disponibles sur le lien suivant: https://cs50.harvard.edu/ai/2023/

Le cour porte à la fois sur les algorithmes utilisés en I.A. et sur leurs implantations en Python. Comme je n’aime ni Python ni les choses simples, j’ai donc décidé de suivre les cours et de reproduire autant que faire se peut les algorithmes en Common Lisp (un language bien plus élégant que Python).

Mon premier algorithme est celui de la recherche de solution. Nous avons une liste avec une série de chiffres, tels que 3756421, c’est l’état initial. Et une autre série de chiffres, tels que 1234567, qui représentent l’objectif à atteindre. À chaque coup, il faut bouger échanger deux chiffres, juste deux chiffres.

Attention, ce n’est pas un algorithme de tri, l’objectif n’est pas de trier les chiffres dans le bon ordre. L’objectif est d’implanter un algorithme de résolution d’un problème par étapes en suivant une règle précise.

Ensuite, nous avons une frontière, c’est la liste des solutions possibles en partant d’un état à l’état suivant. Cette liste est rentrée dans une queue. Puis nous avons un agent qui va vérifier pour chaque entrée de cette queue si elle correspond à l’objectif recherché et si non, chercher tous les états frontières qui n’ont pas déjà été vérifiés et les rajouter dans la queue.

Il s’agit de l’algorithme Breadth-First Search. Malheureusement, il n’est jamais plus fort que l’être humain, mais c’est tout à fait normal, puisqu’il ne connait pas l’objectif à l’avance. Il avance à un peu au hasard et retourne la première solution qu’il a trouvé, même si cette dernière n’est pas forcément la meilleure. On peut améliorer cela si on connait l’objectif en comparant l’état de chaque chiffre avec ceux de l’objectif et donc ne bouger que ceux qui nous en rapprochent. Cela porte un nom, c’est la Greedy Best-First Search.

Mon code source:

#!/opt/homebrew/bin/sbcl --script


(defclass node ()
  ((value :initarg :value
	  :accessor node-value)
   (parent :initform nil
	   :initarg :parent
	   :accessor node-parent)))

(defmethod node-name ((obj node))
  (format nil "~A" (node-value obj)))

(defmethod node-parent-name ((obj node))
  (format nil "~A" (node-parent obj)))

(let ((queue ()))
  (defun add-queue (value)
    (push value queue))
  (defun pull-queue ()
    (let ((ret (first (last queue))))
      (setf queue (reverse (cdr (reverse queue))))
      ret)))

(defvar initial-state (make-instance 'node :value (list 3 1 2 7 5 6 4)))
(defvar target-state (make-instance 'node :value (list 1 2 3 4 5 6 7)))

(defun arrived? (state)
  (equal (node-value state) (node-value target-state)))

(defun exchange (s x y)
  (let ((copy-s (copy-list s)))
    (setf (nth x copy-s) (nth y s))
    (setf (nth y copy-s) (nth x s))
    copy-s))
    
(let ((done-state (make-hash-table :test 'equal))
      (frontiers ()))
  (setf (gethash (node-name initial-state) done-state) initial-state)
  (defun frontiers (state)
    (dotimes (i (- (length state) 1))
      (let* ((proposed-state (exchange state 0 (+ 1 i)))
	     (node (make-instance 'node :value proposed-state :parent state)))
	(when (not (gethash (node-name node) done-state))
	  (setf (gethash (node-name node) done-state) node)
	  (add-queue node)))))
  
  (defun find-path (state li)
    (push (node-name state) li)
    (when (null (node-parent state))
      (return-from find-path li))
    (find-path (gethash (node-parent-name state) done-state) li)))


(defun action (state)
  (frontiers (node-value state))
  (loop
    (let ((ff (pull-queue)))
      (when (null ff)
	(format t "No solution~%"))
      (when (arrived? ff)
	(return-from action ff))
      (frontiers (node-value ff)))))


(let ((ff (action initial-state)))
  (format t "From ~A to ~A~%" (node-name initial-state) (node-name ff))
  (format t "~A~%" (find-path ff () )))