Changeset 14401 in project


Ignore:
Timestamp:
04/24/09 01:38:46 (11 years ago)
Author:
Ivan Raikov
Message:

glpk ported to Chicken 4

Location:
release/4/glpk
Files:
5 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/glpk/trunk/glpk-eggdoc.scm

    r10875 r14401  
    11
    2 (use eggdoc srfi-13)
     2(use eggdoc sxml-transforms srfi-13)
    33
    44(define (s+ . rest) (string-concatenate (map ->string rest)))
     
    1919     (name "glpk")
    2020     (description "GNU Linear Programming Kit (GLPK)")
    21      (author (url "http://chicken.wiki.br/ivan raikov" "Ivan Raikov"))
     21     (author (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov"))
    2222
    2323     (history
     24      (version "1.2" "Ported to Chicken 4")
    2425      (version "1.1" "Added chicken-glpk.h to file manifest")
    2526      (version "1.0" "Initial release"))
     
    604605
    605606(if (eggdoc->html doc
    606                    `( (eggdoc-style . ,(lambda (tag)
     607   `( (eggdoc-style . ,(lambda (tag)
    607608                         `("<style type=\"text/css\">" ,(glpk-eggdoc:css)
    608609                           "</style>")))
    609                       (documentation *macro* . ,(lambda (tag . elts)
    610                         (let* ((sections
    611                                 (pre-post-order elts
    612                                                 `((subsection   ;; (subsection level "content ...")
     610      (documentation *macro* . ,(lambda (tag . elts)
     611                                  (let* ((sections
     612                                          (pre-post-order elts
     613                                                          `((subsection ;; (subsection level "content ...")
    613614                                                   ((*text* . ,(lambda (tag str) str)))
    614615                                                   . ,(lambda (tag head-word . elems)
  • release/4/glpk/trunk/glpk.meta

    r10873 r14401  
     1
     2
    13((egg "glpk.egg") ; This should never change
    24
    35 ; List here all the files that should be bundled as part of your egg. 
    46
    5  (files "glpk.scm" "glpk-eggdoc.scm" "glpk.setup" "chicken-glpk.h" "tests/run.scm")
     7 (files "glpk.scm" "glpk-eggdoc.scm" "glpk.setup" "chicken-glpk.h" "tests")
    68
    79 ; Your egg's license:
  • release/4/glpk/trunk/glpk.scm

    r10749 r14401  
    33;; Chicken interface to the GLPK API.
    44;;
    5 ;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and
    6 ;; Technology.
     5;; Copyright 2008-2009 Ivan Raikov and the Okinawa Institute of
     6;; Science and Technology.
    77;;
    88;; This program is free software: you can redistribute it and/or
     
    2020;;
    2121
    22 (require-extension srfi-1 srfi-4)
    23 
    24 
    25 (define-extension glpk)
    26 
    27 
    28 (declare (export lpx? lpx:empty-problem lpx:make-problem
    29                  lpx:set-problem-name lpx:get-problem-name
    30                  lpx:set-direction lpx:get-direction lpx:set-class lpx:get-class
    31                  lpx:add-rows lpx:add-columns lpx:set-row-name lpx:set-column-name
    32                  lpx:get-column-name lpx:get-row-name lpx:get-num-rows lpx:get-num-columns
    33                  lpx:set-row-bounds lpx:set-column-bounds
    34                  lpx:set-objective-coefficient
    35                  lpx:set-column-kind lpx:load-constraint-matrix
    36                  lpx:get-column-primals lpx:get-objective-value
    37 
    38                  lpx:message_level lpx:scaling lpx:use_dual_simplex
    39                  lpx:pricing lpx:solution_rounding lpx:iteration_limit
    40                  lpx:iteration_count lpx:branching_heuristic
    41                  lpx:backtracking_heuristic lpx:use_presolver
    42                  lpx:relaxation lpx:time_limit
    43 
    44                  LPX_E_OK LPX_E_EMPTY LPX_E_BADB LPX_E_INFEAS
    45                  LPX_E_FAULT LPX_E_OBJLL LPX_E_OBJUL LPX_E_ITLIM
    46                  LPX_E_TMLIM LPX_E_NOFEAS LPX_E_INSTAB LPX_E_SING
    47                  LPX_E_NOCONV LPX_E_NOPFS LPX_E_NODFS
    48                  
    49                  lpx:scale-problem lpx:simplex lpx:integer
    50                  ))
    51 
    52 
     22(module glpk
     23
     24 (lpx? lpx:empty-problem lpx:make-problem
     25       lpx:set-problem-name lpx:get-problem-name
     26       lpx:set-direction lpx:get-direction lpx:set-class lpx:get-class
     27       lpx:add-rows lpx:add-columns lpx:set-row-name lpx:set-column-name
     28       lpx:get-column-name lpx:get-row-name lpx:get-num-rows lpx:get-num-columns
     29       lpx:set-row-bounds lpx:set-column-bounds
     30       lpx:set-objective-coefficient
     31       lpx:set-column-kind lpx:load-constraint-matrix
     32       lpx:get-column-primals lpx:get-objective-value
     33
     34       lpx:message_level lpx:scaling lpx:use_dual_simplex
     35       lpx:pricing lpx:solution_rounding lpx:iteration_limit
     36       lpx:iteration_count lpx:branching_heuristic
     37       lpx:backtracking_heuristic lpx:use_presolver
     38       lpx:relaxation lpx:time_limit
     39       
     40       LPX_E_OK LPX_E_EMPTY LPX_E_BADB LPX_E_INFEAS
     41       LPX_E_FAULT LPX_E_OBJLL LPX_E_OBJUL LPX_E_ITLIM
     42       LPX_E_TMLIM LPX_E_NOFEAS LPX_E_INSTAB LPX_E_SING
     43       LPX_E_NOCONV LPX_E_NOPFS LPX_E_NODFS
     44       
     45       lpx:scale-problem lpx:simplex lpx:integer
     46       )
     47                   
     48 (import scheme chicken foreign srfi-1 srfi-4 )
    5349
    5450#>
     
    151147
    152148;; integer-valued control parameters
    153 (define K_message_level          (foreign-value "LPX_K_MSGLEV" integer))
    154 (define K_scaling                (foreign-value "LPX_K_SCALE"  integer))
    155 (define K_use_dual_simplex       (foreign-value "LPX_K_DUAL"   integer))
    156 (define K_pricing                (foreign-value "LPX_K_PRICE"  integer))
    157 (define K_solution_rounding      (foreign-value "LPX_K_ROUND"  integer))
    158 (define K_iteration_limit        (foreign-value "LPX_K_ITLIM"  integer))
    159 (define K_iteration_count        (foreign-value "LPX_K_ITCNT"  integer))
    160 (define K_branching_heuristic    (foreign-value "LPX_K_BRANCH" integer))
    161 (define K_backtracking_heuristic (foreign-value "LPX_K_BTRACK" integer))
    162 (define K_use_presolver          (foreign-value "LPX_K_PRESOL" integer))
     149(define K_message_level          (foreign-value "LPX_K_MSGLEV" int))
     150(define K_scaling                (foreign-value "LPX_K_SCALE"  int))
     151(define K_use_dual_simplex       (foreign-value "LPX_K_DUAL"   int))
     152(define K_pricing                (foreign-value "LPX_K_PRICE"  int))
     153(define K_solution_rounding      (foreign-value "LPX_K_ROUND"  int))
     154(define K_iteration_limit        (foreign-value "LPX_K_ITLIM"  int))
     155(define K_iteration_count        (foreign-value "LPX_K_ITCNT"  int))
     156(define K_branching_heuristic    (foreign-value "LPX_K_BRANCH" int))
     157(define K_backtracking_heuristic (foreign-value "LPX_K_BTRACK" int))
     158(define K_use_presolver          (foreign-value "LPX_K_PRESOL" int))
    163159;; real-valued control parameters
    164 (define K_relaxation (foreign-value "LPX_K_RELAX" integer))
    165 (define K_time_limit (foreign-value "LPX_K_TMLIM" integer))
     160(define K_relaxation (foreign-value "LPX_K_RELAX" int))
     161(define K_time_limit (foreign-value "LPX_K_TMLIM" int))
    166162
    167163(define lpx_set_int_parameter
    168164    (foreign-lambda* scheme-object ((scheme-object lpx)
    169                                     (integer kindex)
    170                                     (integer val))
     165                                    (int kindex)
     166                                    (int val))
    171167#<<END
    172168     LPX* lp;
     
    183179
    184180(define lpx_get_int_parameter
    185     (foreign-lambda* integer ((scheme-object lpx)
    186                               (integer kindex))
     181    (foreign-lambda* int ((scheme-object lpx)
     182                              (int kindex))
    187183#<<END
    188184     LPX* lp; int result;
     
    200196(define lpx_set_real_parameter
    201197    (foreign-lambda* scheme-object ((scheme-object lpx)
    202                                     (integer kindex)
     198                                    (int kindex)
    203199                                    (double val))
    204200#<<END
     
    217213(define lpx_get_real_parameter
    218214    (foreign-lambda* double ((scheme-object lpx)
    219                              (integer kindex))
     215                             (int kindex))
    220216#<<END
    221217     LPX* lp; double result;
     
    324320(define lpx_set_dir
    325321    (foreign-lambda* scheme-object ((scheme-object lpx)
    326                                     (integer dir))
     322                                    (int dir))
    327323#<<END
    328324     LPX* lp;
     
    342338))     
    343339
    344 (define LPX_MIN   (foreign-value "LPX_MIN" integer) )
    345 (define LPX_MAX   (foreign-value "LPX_MAX" integer) )
     340(define LPX_MIN   (foreign-value "LPX_MIN" int) )
     341(define LPX_MAX   (foreign-value "LPX_MAX" int) )
    346342
    347343
     
    354350
    355351(define lpx_get_dir
    356     (foreign-lambda* integer ((scheme-object lpx))
     352    (foreign-lambda* int ((scheme-object lpx))
    357353#<<END
    358354     LPX* lp; int dir;
     
    378374(define lpx_set_class
    379375    (foreign-lambda* scheme-object ((scheme-object lpx)
    380                                     (integer clss))
     376                                    (int clss))
    381377#<<END
    382378     LPX* lp;
     
    396392))     
    397393
    398 (define LPX_LP   (foreign-value "LPX_LP" integer) )
    399 (define LPX_MIP  (foreign-value "LPX_MIP" integer) )
     394(define LPX_LP   (foreign-value "LPX_LP" int) )
     395(define LPX_MIP  (foreign-value "LPX_MIP" int) )
    400396
    401397
     
    407403   
    408404(define lpx_get_class
    409     (foreign-lambda* integer ((scheme-object lpx))
     405    (foreign-lambda* int ((scheme-object lpx))
    410406#<<END
    411407     LPX* lp; int clss;
     
    430426(define lpx:add-rows
    431427    (foreign-lambda* scheme-object ((scheme-object lpx)
    432                                     (integer nrows))
     428                                    (int nrows))
    433429#<<END
    434430     LPX* lp;
     
    450446
    451447(define lpx:get-num-rows
    452     (foreign-lambda* integer ((scheme-object lpx))
     448    (foreign-lambda* int ((scheme-object lpx))
    453449#<<END
    454450     LPX* lp; int result;
     
    468464(define lpx:add-columns
    469465    (foreign-lambda* scheme-object ((scheme-object lpx)
    470                                     (integer ncols))
     466                                    (int ncols))
    471467#<<END
    472468     LPX* lp;
     
    488484
    489485(define lpx:get-num-columns
    490     (foreign-lambda* integer ((scheme-object lpx))
     486    (foreign-lambda* int ((scheme-object lpx))
    491487#<<END
    492488     LPX* lp; int result;
     
    505501(define lpx:set-row-name
    506502    (foreign-lambda* scheme-object ((scheme-object lpx)
    507                                     (integer i)
     503                                    (int i)
    508504                                    (c-string name))
    509505#<<END
     
    527523(define lpx:set-column-name
    528524    (foreign-lambda* scheme-object ((scheme-object lpx)
    529                                     (integer j)
     525                                    (int j)
    530526                                    (c-string name))
    531527#<<END
     
    549545(define lpx:get-row-name
    550546    (foreign-lambda* c-string ((scheme-object lpx)
    551                                (integer i))
     547                               (int i))
    552548#<<END
    553549     LPX* lp; char *result;
     
    570566(define lpx:get-column-name
    571567  (foreign-lambda* c-string ((scheme-object lpx)
    572                              (integer i))
     568                             (int i))
    573569#<<END
    574570     LPX* lp; char *result;
     
    589585
    590586
    591 (define LPX_LO   (foreign-value "LPX_LO" integer))
    592 (define LPX_UP   (foreign-value "LPX_UP" integer))
    593 (define LPX_DB   (foreign-value "LPX_DB" integer))
    594 (define LPX_FX   (foreign-value "LPX_FX" integer))
    595 (define LPX_FR   (foreign-value "LPX_FR" integer))
     587(define LPX_LO   (foreign-value "LPX_LO" int))
     588(define LPX_UP   (foreign-value "LPX_UP" int))
     589(define LPX_DB   (foreign-value "LPX_DB" int))
     590(define LPX_FX   (foreign-value "LPX_FX" int))
     591(define LPX_FR   (foreign-value "LPX_FR" int))
    596592
    597593
    598594(define lpx_set_row_bounds
    599595    (foreign-lambda* scheme-object ((scheme-object lpx)
    600                                     (integer i)
    601                                     (integer typx)
     596                                    (int i)
     597                                    (int typx)
    602598                                    (double lb) (double ub)
    603599                                    )
     
    622618(define lpx_set_col_bounds
    623619    (foreign-lambda* scheme-object ((scheme-object lpx)
    624                                     (integer j)
    625                                     (integer typx)
     620                                    (int j)
     621                                    (int typx)
    626622                                    (double lb) (double ub)
    627623                                    )
     
    671667(define lpx_get_column_primals
    672668    (foreign-lambda* void ((scheme-object lpx)
    673                            (integer n)
     669                           (int n)
    674670                           (f64vector v)
    675671                           )
     
    714710(define lpx:set-objective-coefficient
    715711    (foreign-lambda* scheme-object ((scheme-object lpx)
    716                                     (integer j)
     712                                    (int j)
    717713                                    (double coef)
    718714                                    )
     
    736732
    737733
    738 (define LPX_CV   (foreign-value "LPX_CV" integer))
    739 (define LPX_IV   (foreign-value "LPX_IV" integer))
     734(define LPX_CV   (foreign-value "LPX_CV" int))
     735(define LPX_IV   (foreign-value "LPX_IV" int))
    740736
    741737(define lpx_set_column_kind
    742738    (foreign-lambda* scheme-object ((scheme-object lpx)
    743                                     (integer j)
    744                                     (integer kind)
     739                                    (int j)
     740                                    (int kind)
    745741                                    )
    746742#<<END
     
    774770(define lpx_load_constraint_matrix
    775771    (foreign-lambda* scheme-object ((scheme-object lpx)
    776                                     (integer nrows)
    777                                     (integer ncols)
     772                                    (int nrows)
     773                                    (int ncols)
    778774                                    (char order)
    779775                                    (f64vector m)
     
    851847
    852848
    853 (define LPX_E_OK      (foreign-value "LPX_E_OK" integer))        ;;   /* success */
    854 (define LPX_E_EMPTY   (foreign-value "LPX_E_EMPTY" integer))     ;;   /* empty problem */
    855 (define LPX_E_BADB    (foreign-value "LPX_E_BADB" integer))      ;;   /* invalid initial basis */
    856 (define LPX_E_INFEAS  (foreign-value "LPX_E_INFEAS" integer))    ;;   /* infeasible initial solution */
    857 (define LPX_E_FAULT   (foreign-value "LPX_E_FAULT" integer))     ;;   /* unable to start the search */
    858 (define LPX_E_OBJLL   (foreign-value "LPX_E_OBJLL" integer))     ;;   /* objective lower limit reached */
    859 (define LPX_E_OBJUL   (foreign-value "LPX_E_OBJUL" integer))     ;;   /* objective upper limit reached */
    860 (define LPX_E_ITLIM   (foreign-value "LPX_E_ITLIM" integer))     ;;   /* iterations limit exhausted */
    861 (define LPX_E_TMLIM   (foreign-value "LPX_E_TMLIM" integer))     ;;   /* time limit exhausted */
    862 (define LPX_E_NOFEAS  (foreign-value "LPX_E_NOFEAS" integer))    ;;   /* no feasible solution */
    863 (define LPX_E_INSTAB  (foreign-value "LPX_E_INSTAB" integer))    ;;   /* numerical instability */
    864 (define LPX_E_SING    (foreign-value "LPX_E_SING" integer))      ;;   /* problems with basis matrix */
    865 (define LPX_E_NOCONV  (foreign-value "LPX_E_NOCONV" integer))    ;;   /* no convergence (interior) */
    866 (define LPX_E_NOPFS   (foreign-value "LPX_E_NOPFS" integer))     ;;   /* no primal feas. sol. (LP presolver) */
    867 (define LPX_E_NODFS   (foreign-value "LPX_E_NODFS" integer))     ;;   /* no dual feas. sol. (LP presolver) */
     849(define LPX_E_OK      (foreign-value "LPX_E_OK" int))        ;;   /* success */
     850(define LPX_E_EMPTY   (foreign-value "LPX_E_EMPTY" int))     ;;   /* empty problem */
     851(define LPX_E_BADB    (foreign-value "LPX_E_BADB" int))      ;;   /* invalid initial basis */
     852(define LPX_E_INFEAS  (foreign-value "LPX_E_INFEAS" int))    ;;   /* infeasible initial solution */
     853(define LPX_E_FAULT   (foreign-value "LPX_E_FAULT" int))     ;;   /* unable to start the search */
     854(define LPX_E_OBJLL   (foreign-value "LPX_E_OBJLL" int))     ;;   /* objective lower limit reached */
     855(define LPX_E_OBJUL   (foreign-value "LPX_E_OBJUL" int))     ;;   /* objective upper limit reached */
     856(define LPX_E_ITLIM   (foreign-value "LPX_E_ITLIM" int))     ;;   /* iterations limit exhausted */
     857(define LPX_E_TMLIM   (foreign-value "LPX_E_TMLIM" int))     ;;   /* time limit exhausted */
     858(define LPX_E_NOFEAS  (foreign-value "LPX_E_NOFEAS" int))    ;;   /* no feasible solution */
     859(define LPX_E_INSTAB  (foreign-value "LPX_E_INSTAB" int))    ;;   /* numerical instability */
     860(define LPX_E_SING    (foreign-value "LPX_E_SING" int))      ;;   /* problems with basis matrix */
     861(define LPX_E_NOCONV  (foreign-value "LPX_E_NOCONV" int))    ;;   /* no convergence (interior) */
     862(define LPX_E_NOPFS   (foreign-value "LPX_E_NOPFS" int))     ;;   /* no primal feas. sol. (LP presolver) */
     863(define LPX_E_NODFS   (foreign-value "LPX_E_NODFS" int))     ;;   /* no dual feas. sol. (LP presolver) */
    868864
    869865
    870866(define lpx:simplex
    871     (foreign-lambda* integer ((scheme-object lpx))
     867    (foreign-lambda* int ((scheme-object lpx))
    872868                                   
    873869#<<END
     
    887883
    888884(define lpx:integer
    889     (foreign-lambda* integer ((scheme-object lpx))
     885    (foreign-lambda* int ((scheme-object lpx))
    890886                                   
    891887#<<END
     
    941937       lpx))))
    942938
    943          
    944    
     939)
  • release/4/glpk/trunk/glpk.setup

    r10875 r14401  
    1 
    2 (define has-exports? (string>=? (chicken-version) "2.310"))
     1;; -*- Hen -*-
    32
    43(define (dynld-name fn)         
     
    87  (and (try-compile
    98        (string-append header "\n"
    10                         "int main(int argc, char **argv) { glp_create_prob(); return 0; }\n")
     9                       "int main(int argc, char **argv) { glp_create_prob(); return 0; }\n")
    1110        ldflags: ldflags
    12         cflags: cppflags
    13         )
     11        cflags: cppflags)
    1412       (cons ldflags cppflags)))
    1513
    16 (define-macro (glpk-test . rest)
    17   `(or (any identity (map (lambda (p) (glpk-try-compile (first p) (second p) (third p))) ',rest))
    18        (error "unable to figure out location of GLPK library")))
     14(define-syntax glpk-test
     15  (syntax-rules ()
     16    ((_ (flags ...))
     17     (condition-case (glpk-try-compile flags ...)
     18                     (t ()    #f)))))
    1919
    2020(define ld+cpp-options
    21   (glpk-test ("#include <glpk.h>" "-lglpk" "-I.")
    22              ("#include <glpk.h>" "-lglpk" "-I. -I/usr/include/glpk")
    23              ("#include <glpk.h>" "-lglpk" "-I. -I/opt/local/include")))
     21  (or (glpk-test ("#include <glpk.h>" "-lglpk" "-I."))
     22      (glpk-test ("#include <glpk.h>" "-lglpk" "-I. -I/usr/include/glpk"))
     23      (glpk-test ("#include <glpk.h>" "-lglpk" "-I. -I/opt/local/include"))
     24      (error "unable to figure out location of GLPK library")))
    2425
    25 (compile -O -d2 -s -o ,(dynld-name "glpk")
    26          ,@(if has-exports? '(-check-imports -emit-exports glpk.exports) '())
    27          glpk.scm  -lchicken -ldl  -L "\"" ,(car ld+cpp-options) "\""
     26(compile -O2 -d0 -I. -s glpk.scm  -j glpk
     27         -L "\"" ,(car ld+cpp-options) "\""
    2828         -C "\"" ,(cdr ld+cpp-options) "\"")
     29(compile -O2 -d0 -s glpk.import.scm)
    2930
    30 (run (csi -qbs glpk-eggdoc.scm > glpk.html))
     31(run (csi -s glpk-eggdoc.scm > glpk.html))
    3132
    3233(install-extension
     
    3637
    3738  ; Files to install for your extension:
    38   `(,(dynld-name "glpk") )
     39  `(,(dynld-name "glpk") ,(dynld-name "glpk.import") )
    3940
    4041  ; Assoc list with properties for your extension:
    41   `((version 1.1)
    42     (documentation "glpk.html")
    43     ,@(if has-exports? `((exports "glpk.exports")) (list)) ))
     42  `((version 1.2)
     43    (documentation "glpk.html")))
  • release/4/glpk/trunk/tests/run.scm

    r10706 r14401  
    1515;;    x1 >= 0, x2 >= 0, x3 >= 0
    1616
    17 (require-extension srfi-4)
    18 (require-extension glpk)
     17(require-extension srfi-1 srfi-4 glpk)
     18(import srfi-1 srfi-4 glpk)
     19
    1920
    2021;; Auxiliary variables (rows)
Note: See TracChangeset for help on using the changeset viewer.