X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql.lisp;h=82af22b282da669dd8a92b4e233060ace99d01b9;hb=88be55a3921b3078570bb737da197c671117a719;hp=94a7243e9da75dbbeeb019516f1405b4f1008de9;hpb=77d1409857f947a3fd9e8a07d19ff937952a25b5;p=umlisp.git diff --git a/sql.lisp b/sql.lisp index 94a7243..82af22b 100644 --- a/sql.lisp +++ b/sql.lisp @@ -2,30 +2,42 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: sql.lisp -;;;; Purpose: Low-level SQL routines data for UMLisp -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 +;;;; Name: sql.lisp +;;;; Purpose: Low-level SQL routines data for UMLisp +;;;; Author: Kevin M. Rosenberg +;;;; Created: Apr 2000 ;;;; -;;;; $Id: sql.lisp,v 1.4 2002/10/16 15:22:28 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is -;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. +;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* -(in-package :umlisp) -(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) +(in-package #:umlisp) +(defvar +umls-sql-map+ + '((:2004aa . "KUMLS2004AA") + (:2006ac . "KUMLS2006AC") + (:2006ad . "MTS2006AD"))) +(defvar +default-umls-db+ "MTS2006AD") -(defvar *umls-sql-dsn* "KUMLS2002AC") -(defun umls-sql-dsn () - *umls-sql-dsn*) -(defun umls-sql-dsn! (dbname) - (sql-disconnect-pooled) - (setq *umls-sql-dsn* dbname)) + +(defun lookup-db-name (db) + (cdr (assoc (ensure-keyword db) +umls-sql-map+))) + +(defvar *umls-sql-db* +default-umls-db+) +(defun umls-sql-db () + *umls-sql-db*) + +(defun umls-sql-db! (db) + (etypecase db + (string + (setq *umls-sql-db* db)) + (keyword + (setq *umls-sql-db* (lookup-db-name db))))) (defvar *umls-sql-user* "secret") (defun umls-sql-user () @@ -55,9 +67,13 @@ (sql-disconnect-pooled) (setq *umls-sql-type* h)) +(defun umls-connection-spec () + (list *umls-sql-host* *umls-sql-db* + *umls-sql-user* *umls-sql-passwd*)) + (defun sql-connect () "Connect to UMLS database, automatically used pooled connections" - (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(umls-sql-user) ,(umls-sql-passwd)) + (clsql:connect (umls-connection-spec) :database-type *umls-sql-type* :pool t)) (defun sql-disconnect (conn) @@ -73,17 +89,17 @@ (progn ,@body) (when ,conn (clsql:disconnect :database ,conn))))) +(defun sql-query (cmd conn &key (result-types :auto)) + (clsql:query cmd :database conn :result-types result-types :field-names nil)) + +(defun sql-execute (cmd conn) + (clsql:execute-command cmd :database conn)) + (defun sql (stmt conn) (if (string-equal "SELECT" (subseq stmt 0 6)) (sql-query stmt conn) (sql-execute stmt conn))) -(defun sql-query (cmd conn &key (types :auto)) - (clsql:query cmd :database conn :types types)) - -(defun sql-execute (cmd conn) - (clsql:execute-command cmd :database conn)) - (defun umls-sql (stmt) (check-type stmt string) (with-sql-connection (conn) @@ -101,80 +117,6 @@ (with-mutex-sql (conn) (sql-execute cmd conn))) -(defun mutex-sql-query (cmd &key (types :auto)) +(defun mutex-sql-query (cmd &key (result-types :auto)) (with-mutex-sql (conn) - (sql-query cmd conn :types types))) - - - -(defun make-usrl () - (with-sql-connection (conn) - (sql-execute "drop table if exists USRL" conn) - (sql-execute "create table USRL (sab varchar(80), srl integer)" conn) - (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc")) - (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" - (car tuple) (ensure-integer (cadr tuple))) - conn))) - (find-usrl-all)) - -(defun find-usrl-all () - (let ((usrls '()) - (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc"))) - (dolist (tuple tuples) - (push (make-instance 'usrl :sab (nth 0 tuple) - :srl (ensure-integer (nth 1 tuple))) usrls)) - usrls)) - -;; already reversed by sql - -(defun find-usrl_freq-all () - (let ((freqs '())) - (dolist (usrl (find-usrl-all)) - (let ((freq (ensure-integer - (caar (mutex-sql-query - (format nil "select count(*) from MRSO where SAB='~a'" - (sab usrl))))))) - (push (make-instance 'usrl_freq :usrl usrl :freq freq) freqs))) - (sort freqs #'> :key #'usrl_freq-freq))) - - -(defun find-ucon-normalized-multiword (str &key (srl *current-srl*)) - "Return sorted list of ucon's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ucons '()) - (nwords '())) - (dolist (word words) - (let ((nws (lvg:process-terms word))) - (dolist (nword nws) - (push nword nwords)))) - (dolist (word nwords) - (setq ucons (append ucons (find-ucon-word word :srl srl)))) - (umlisp::sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) -(defun find-ustr-normalized-multiword (str &key (srl *current-srl*)) - "Return sorted list of ustr's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ustrs '()) - (nwords '())) - (dolist (word words) - (let ((nws (lvg:process-terms word))) - (dolist (nword nws) - (push nword nwords)))) - (dolist (word nwords) - (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) - (umlisp::sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui)))) - -(defun a (str) - (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui)) - -(defun find-normalized-matches-for-str (str lookup-func key-func) - "Return list of objects that normalize match for words in string, -eliminate duplicates." - (let ((objs '()) - (nwords '())) - (dolist (word (delimited-string-to-list str #\space)) - (dolist (nword (lvg:process-terms word)) - (unless (member nword nwords :test #'string-equal) - (push nword nwords)))) - (dolist (nw nwords) - (setq objs (append objs (funcall lookup-func nw)))) - (delete-duplicates objs :key key-func :test #'eql))) + (sql-query cmd conn :result-types result-types)))