;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: sql-classes.lisp,v 1.88 2003/07/21 00:53:27 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.89 2003/07/21 09:46:22 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
(defmacro umlisp-query (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like)
+ &key (lrl "KCUILRL") single distinct order like
+ (query-cmd 'mutex-sql-query))
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
- `(mutex-sql-query
+ `(,query-cmd
(query-string ,table ,fields ,srl ,where-name ,where-value
:lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
;; only WHERE-VALUE and SRL are evaluated
(defmacro collect-umlisp-query ((table fields srl where-name where-value
&key (lrl "KCUILRL") distinct single
- order like)
- &body body)
+ order like (query-cmd 'mutex-sql-query))
+ &body body)
(let ((value (gensym))
(r (gensym)))
(if single
(tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
:lrl ,lrl :single ,single
:distinct ,distinct :order ,order
- :like ,like))))
+ :like ,like
+ :query-cmd ,query-cmd))))
,@(unless where-name `((declare (ignore ,value))))
(when tuple
(destructuring-bind ,fields tuple
(defun find-sstr-styrl (styrl)
(collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
(make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
+
+
+;;; **************************
+;;; Local Classes
+;;; **************************
+
+
+(defun make-ustats ()
+ (with-sql-connection (conn)
+ (sql-execute "drop table if exists USTATS" conn)
+ (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
+
+ (dotimes (srl 4)
+ (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl)
+ (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl)
+ (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl)
+ (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl)
+ (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl)
+ (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl)
+ (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl)
+ (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
+ (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
+ (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl)
+ (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
+ (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
+ (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
+ (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
+ (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl)
+ (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl)
+ (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl)
+ (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl)
+ (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl))
+ (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
+ (find-ustats-all))
+
+(defun insert-ustats-count (conn name table count-variable srl-control srl)
+ (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl))
+
+(defun find-count-table (conn table srl count-variable srl-control)
+ (cond
+ ((stringp srl-control)
+ (ensure-integer
+ (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
+ count-variable table srl-control srl)
+ conn))))
+ ((null srl-control)
+ (ensure-integer
+ (caar (sql-query (format nil "select count(~a) from ~a"
+ count-variable table )
+ conn))))
+ (t
+ (error "Unknown srl-control")
+ 0)))
+
+(defun insert-ustats (conn name count srl)
+ (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
+ name count (if srl srl 3))
+ conn))
+
+(defun find-ustats-all (&key (srl *current-srl*))
+ (collect-umlisp-query (ustats (name count srl) nil srl srl
+ :order (name asc))
+ (make-instance 'ustats :name name :hits (ensure-integer count)
+ :srl (ensure-integer srl))))
+
+(defun find-ustats-srl (srl)
+ (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
+ (make-instance 'ustats :name name :hits (ensure-integer count))))
+
+
+
+(defun find-bsab-sab (sab)
+ (collect-umlisp-query (bonus_sab (name count) nil sab sab :single t)
+ (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-bsab-all ()
+ (collect-umlisp-query (bonus_sab (sab name count) nil nil nil :order (sab asc))
+ (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-btty-tty (tty)
+ (:collect-umlisp-query (bonus_tty (name count) nil tty tty :single t)
+ (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-btty-all ()
+ (u::collect-umlisp-query (bonus_tty (tty name count) nil nil nil :order (tty asc))
+ (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-brel-rel (rel)
+ (u::collect-umlisp-query (bonus_rel (sab sl rel rela count) nil rel rel)
+ (make-instance 'brel :sab sab :sl sl :rel rel :rela rela
+ :hits (ensure-integer count))))
+
projects / umlisp.git / blobdiff