source: project/release/4/glpk/trunk/glpk.scm @ 14401

Last change on this file since 14401 was 14401, checked in by Ivan Raikov, 11 years ago

glpk ported to Chicken 4

File size: 22.0 KB
Line 
1
2;;
3;; Chicken interface to the GLPK API.
4;;
5;; Copyright 2008-2009 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
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 )
49
50#>
51
52#include <glpk.h>
53#include <chicken-glpk.h>
54
55#define ERR_INVALID_LPX        1
56#define ERR_INVALID_LPX_DIR    2
57#define ERR_INVALID_LPX_CLASS  3
58#define ERR_NEG_IND            4
59#define ERR_INVALID_COL_KIND   5
60#define ERR_INVALID_MAT_ORD    6
61
62
63static C_word LPX_p(C_word obj) 
64{
65  if (C_immediatep(obj)) {
66    return C_SCHEME_FALSE;
67  } else if (C_block_header(obj) == LPX_TAG) 
68  {
69    return C_SCHEME_TRUE;
70  } else {
71    return C_SCHEME_FALSE;
72  }
73}
74
75
76static void chicken_Panic (C_char *) C_noret;
77static void chicken_Panic (C_char *msg)
78{
79  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
80  C_word scmmsg = C_string2 (&a, msg);
81  C_halt (scmmsg);
82  exit (5); /* should never get here */
83}
84
85static void chicken_ThrowException(C_word value) C_noret;
86static void chicken_ThrowException(C_word value)
87{
88  char *aborthook = C_text("\003sysabort");
89
90  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
91  C_word abort = C_intern2(&a, aborthook);
92
93  abort = C_block_item(abort, 0);
94  if (C_immediatep(abort))
95    chicken_Panic(C_text("`##sys#abort' is not defined"));
96
97  C_save(value);
98  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
99}
100
101void chicken_LPX_exception (int code, int msglen, const char *msg) 
102{
103  C_word *a;
104  C_word scmmsg;
105  C_word list;
106
107  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
108  scmmsg = C_string2 (&a, (char *) msg);
109  list = C_list(&a, 2, C_fix(code), scmmsg);
110  chicken_ThrowException(list);
111}
112
113
114static C_word check_LPX (C_word obj) 
115{
116  if (C_immediatep(obj)) 
117  {
118    chicken_LPX_exception (ERR_INVALID_LPX, 18, "invalid LPX object");
119  } else if (C_block_header(obj) == LPX_TAG) 
120  {
121    return C_SCHEME_UNDEFINED;
122  } else {
123    chicken_LPX_exception (ERR_INVALID_LPX, 18, "invalid LPX object");
124  }
125}
126
127<#
128
129(define lpx? (foreign-lambda scheme-object "LPX_p" scheme-object))
130
131(define lpx:empty-problem 
132    (foreign-primitive scheme-object ()
133#<<END
134   C_word result;
135   chicken_LPX_t newlpx;
136   LPX* lpx;
137   
138   lpx = lpx_create_prob();
139
140   newlpx.tag = LPX_TAG;
141   newlpx.lpx_data = lpx;
142   result = (C_word)&newlpx;
143
144   C_return (result);
145END
146))
147
148;; integer-valued control parameters
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))
159;; real-valued control parameters
160(define K_relaxation (foreign-value "LPX_K_RELAX" int))
161(define K_time_limit (foreign-value "LPX_K_TMLIM" int))
162
163(define lpx_set_int_parameter
164    (foreign-lambda* scheme-object ((scheme-object lpx)
165                                    (int kindex)
166                                    (int val))
167#<<END
168     LPX* lp;
169
170     check_LPX(lpx);
171
172     lp = LPX_val(lpx);
173
174     lpx_set_int_parm (lp, kindex, val);
175
176     C_return(lpx);
177END
178))     
179
180(define lpx_get_int_parameter
181    (foreign-lambda* int ((scheme-object lpx)
182                              (int kindex))
183#<<END
184     LPX* lp; int result;
185
186     check_LPX(lpx);
187
188     lp = LPX_val(lpx);
189
190     result = lpx_get_int_parm (lp, kindex);
191
192     C_return(result);
193END
194))     
195
196(define lpx_set_real_parameter
197    (foreign-lambda* scheme-object ((scheme-object lpx)
198                                    (int kindex)
199                                    (double val))
200#<<END
201     LPX* lp;
202
203     check_LPX(lpx);
204
205     lp = LPX_val(lpx);
206
207     lpx_set_real_parm (lp, kindex, val);
208
209     C_return(lpx);
210END
211))     
212
213(define lpx_get_real_parameter
214    (foreign-lambda* double ((scheme-object lpx)
215                             (int kindex))
216#<<END
217     LPX* lp; double result;
218
219     check_LPX(lpx);
220
221     lp = LPX_val(lpx);
222
223     result = lpx_get_real_parm (lp, kindex);
224
225     C_return(result);
226END
227))     
228
229(define (make-lpx-parameter kindex typ )
230  (if (list? typ)
231      (lambda (lpx . rest) 
232        (if (null? rest) 
233            (let ((val (lpx_get_int_parameter lpx kindex)))
234              (cadr (find (lambda (p) (eq? (car p) val)) typ)))
235            (let* ((val (car rest))
236                   (to-val (car (find (lambda (p) (eq? (cadr p) val)) typ))))
237              (lpx_set_int_parameter lpx kindex to-val))))
238      (case typ
239        ((bool boolean)   
240         (lambda (lpx . rest) 
241           (if (null? rest) 
242               (let ((val (lpx_get_int_parameter lpx kindex)))  (= val 1))
243               (let* ((val (car rest)))
244                 (if val (lpx_set_int_parameter lpx kindex 1)
245                     (lpx_set_int_parameter lpx kindex 0))))))
246        ((int integer)
247         (lambda (lpx . rest) 
248           (if (null? rest) 
249               (lpx_get_int_parameter lpx kindex)
250               (let* ((val (car rest)))
251                 (lpx_set_int_parameter lpx kindex val)))))
252        ((real)
253         (lambda (lpx . rest) 
254           (if (null? rest) 
255               (lpx_get_real_parameter lpx kindex)
256               (let* ((val (car rest)))
257                 (lpx_set_real_parameter lpx kindex val)))))
258        (else (error 'make-lpx-parameter "unknown type" typ)))))
259         
260
261;; integer-valued control parameters
262(define lpx:message_level
263  (make-lpx-parameter K_message_level `((0 none) (1 error) (2 normal) (3 full))))
264(define lpx:scaling               
265  (make-lpx-parameter K_scaling `((0 none) (1 equilibration) (2 geometric-mean) (3 geometric-mean+equilibration))))
266(define lpx:use_dual_simplex       
267  (make-lpx-parameter K_use_dual_simplex `bool))
268(define lpx:pricing               
269  (make-lpx-parameter K_pricing `((0 textbook) (1 steepest-edge))))
270(define lpx:solution_rounding     
271  (make-lpx-parameter K_solution_rounding `bool))
272(define lpx:iteration_limit       
273  (make-lpx-parameter K_iteration_limit `int))
274(define lpx:iteration_count       
275  (make-lpx-parameter K_iteration_count `int))
276(define lpx:branching_heuristic   
277  (make-lpx-parameter K_branching_heuristic `((0 first) (1 last) (2 driebeck+tomlin))))
278(define lpx:backtracking_heuristic 
279  (make-lpx-parameter K_backtracking_heuristic `((0 dfs) (1 bfs) (2 best-projection) (3 best-local-bound))))
280(define lpx:use_presolver         
281  (make-lpx-parameter K_use_presolver `bool))
282;; real-valued control parameters
283(define lpx:relaxation (make-lpx-parameter K_relaxation `real))
284(define lpx:time_limit (make-lpx-parameter K_time_limit `real))
285 
286
287(define lpx:set-problem-name 
288    (foreign-lambda* scheme-object ((scheme-object lpx)
289                                    (c-string name))
290#<<END
291     LPX* lp;
292
293     check_LPX(lpx);
294
295     lp = LPX_val(lpx);
296
297     lpx_set_prob_name (lp, name);
298
299     C_return(lpx);
300END
301))     
302
303
304(define lpx:get-problem-name 
305    (foreign-lambda* c-string ((scheme-object lpx))
306#<<END
307     LPX* lp; char *result;
308
309     check_LPX(lpx);
310
311     lp = LPX_val(lpx);
312
313     result = lpx_get_prob_name (lp);
314
315     C_return(result);
316END
317))     
318
319
320(define lpx_set_dir 
321    (foreign-lambda* scheme-object ((scheme-object lpx)
322                                    (int dir))
323#<<END
324     LPX* lp;
325
326     check_LPX(lpx);
327     if (!((dir == LPX_MIN) || (dir == LPX_MAX)))
328     {
329       chicken_LPX_exception (ERR_INVALID_LPX_DIR, 21, "invalid LPX direction");
330     }
331
332     lp = LPX_val(lpx);
333
334     lpx_set_obj_dir (lp, dir);
335
336     C_return(lpx);
337END
338))     
339
340(define LPX_MIN   (foreign-value "LPX_MIN" int) )
341(define LPX_MAX   (foreign-value "LPX_MAX" int) )
342
343
344(define (lpx:set-direction lpx dir)
345  (case dir
346    ((min minimize)   (lpx_set_dir lpx LPX_MIN))
347    ((max maximize)   (lpx_set_dir lpx LPX_MAX))
348    (else   (error 'lpx:set-direction "invalid direction" dir))))
349   
350
351(define lpx_get_dir 
352    (foreign-lambda* int ((scheme-object lpx))
353#<<END
354     LPX* lp; int dir;
355
356     check_LPX(lpx);
357
358     lp = LPX_val(lpx);
359
360     dir = lpx_get_obj_dir (lp);
361
362     C_return(dir);
363END
364))     
365
366
367(define (lpx:get-direction lpx)
368  (let ((dir (lpx_get_dir lpx)))
369    (cond
370     ((= LPX_MIN dir)  'minimize)
371     ((= LPX_MAX dir)  'maximize)
372     (else   (error 'lpx:get-direction "unknown direction" dir)))))
373
374(define lpx_set_class 
375    (foreign-lambda* scheme-object ((scheme-object lpx)
376                                    (int clss))
377#<<END
378     LPX* lp;
379
380     check_LPX(lpx);
381     if (!((clss == LPX_LP) || (clss == LPX_MIP)))
382     {
383       chicken_LPX_exception (ERR_INVALID_LPX_CLASS, 17, "invalid LPX class");
384     }
385
386     lp = LPX_val(lpx);
387
388     lpx_set_class (lp, clss);
389
390     C_return(lpx);
391END
392))     
393
394(define LPX_LP   (foreign-value "LPX_LP" int) )
395(define LPX_MIP  (foreign-value "LPX_MIP" int) )
396
397
398(define (lpx:set-class lpx clss)
399  (case clss
400    ((lp)   (lpx_set_class lpx LPX_LP))
401    ((mip)  (lpx_set_class lpx LPX_MIP))
402    (else   (error 'lpx:set-class "invalid class" clss))))
403   
404(define lpx_get_class 
405    (foreign-lambda* int ((scheme-object lpx))
406#<<END
407     LPX* lp; int clss;
408
409     check_LPX(lpx);
410
411     lp = LPX_val(lpx);
412
413     clss = lpx_get_class (lp);
414
415     C_return(clss);
416END
417))     
418
419(define (lpx:get-class lpx)
420  (let ((clss (lpx_get_class lpx)))
421    (cond
422     ((= LPX_LP clss)  'lp)
423     ((= LPX_MIP clss) 'mip)
424     (else   (error 'lpx:get-class "unknown class" clss)))))
425
426(define lpx:add-rows 
427    (foreign-lambda* scheme-object ((scheme-object lpx)
428                                    (int nrows))
429#<<END
430     LPX* lp;
431
432     check_LPX(lpx);
433     if (!(nrows > 0))
434     {
435       chicken_LPX_exception (ERR_NEG_IND, 22, "nrows must be positive");
436     }
437
438     lp = LPX_val(lpx);
439
440     lpx_add_rows (lp, nrows);
441
442     C_return(lpx);
443END
444))     
445
446
447(define lpx:get-num-rows 
448    (foreign-lambda* int ((scheme-object lpx))
449#<<END
450     LPX* lp; int result;
451
452     check_LPX(lpx);
453
454     lp = LPX_val(lpx);
455
456     result = lpx_get_num_rows (lp);
457
458     C_return(result);
459END
460))     
461
462
463
464(define lpx:add-columns 
465    (foreign-lambda* scheme-object ((scheme-object lpx)
466                                    (int ncols))
467#<<END
468     LPX* lp;
469
470     check_LPX(lpx);
471     if (!(ncols > 0))
472     {
473       chicken_LPX_exception (ERR_NEG_IND, 22, "ncols must be positive");
474     }
475
476     lp = LPX_val(lpx);
477
478     lpx_add_cols (lp, ncols);
479
480     C_return(lpx);
481END
482))     
483
484
485(define lpx:get-num-columns 
486    (foreign-lambda* int ((scheme-object lpx))
487#<<END
488     LPX* lp; int result;
489
490     check_LPX(lpx);
491
492     lp = LPX_val(lpx);
493
494     result = lpx_get_num_cols (lp);
495
496     C_return(result);
497END
498))     
499
500
501(define lpx:set-row-name 
502    (foreign-lambda* scheme-object ((scheme-object lpx)
503                                    (int i)
504                                    (c-string name))
505#<<END
506     LPX* lp;
507
508     check_LPX(lpx);
509     if (!(i >= 0))
510     {
511       chicken_LPX_exception (ERR_NEG_IND, 34, "row index must be zero or positive");
512     }
513
514     lp = LPX_val(lpx);
515
516     lpx_set_row_name (lp, i, name);
517
518     C_return(lpx);
519END
520))     
521
522
523(define lpx:set-column-name 
524    (foreign-lambda* scheme-object ((scheme-object lpx)
525                                    (int j)
526                                    (c-string name))
527#<<END
528     LPX* lp;
529
530     check_LPX(lpx);
531
532     if (!(j >= 0))
533     {
534       chicken_LPX_exception (ERR_NEG_IND, 37, "column index must be zero or positive");
535     }
536
537     lp = LPX_val(lpx);
538
539     lpx_set_col_name (lp, j, name);
540
541     C_return(lpx);
542END
543))     
544
545(define lpx:get-row-name 
546    (foreign-lambda* c-string ((scheme-object lpx)
547                               (int i))
548#<<END
549     LPX* lp; char *result;
550
551     check_LPX(lpx);
552     if (!(i >= 0))
553     {
554       chicken_LPX_exception (ERR_NEG_IND, 34, "row index must be zero or positive");
555     }
556
557     lp = LPX_val(lpx);
558
559     result = lpx_get_row_name (lp, i);
560
561     C_return(result);
562END
563))     
564
565
566(define lpx:get-column-name 
567  (foreign-lambda* c-string ((scheme-object lpx)
568                             (int i))
569#<<END
570     LPX* lp; char *result;
571
572     check_LPX(lpx);
573     if (!(i >= 0))
574     {
575       chicken_LPX_exception (ERR_NEG_IND, 37, "column index must be zero or positive");
576     }
577
578     lp = LPX_val(lpx);
579
580     result = lpx_get_col_name (lp, i);
581
582     C_return(result);
583END
584))     
585
586
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))
592
593
594(define lpx_set_row_bounds 
595    (foreign-lambda* scheme-object ((scheme-object lpx)
596                                    (int i)
597                                    (int typx)
598                                    (double lb) (double ub)
599                                    )
600#<<END
601     LPX* lp;
602
603     check_LPX(lpx);
604     if (!(i >= 0))
605     {
606       chicken_LPX_exception (ERR_NEG_IND, 34, "row index must be zero or positive");
607     }
608
609     lp = LPX_val(lpx);
610
611     lpx_set_row_bnds (lp, i, typx, lb, ub);
612
613     C_return(lpx);
614END
615))     
616
617
618(define lpx_set_col_bounds 
619    (foreign-lambda* scheme-object ((scheme-object lpx)
620                                    (int j)
621                                    (int typx)
622                                    (double lb) (double ub)
623                                    )
624#<<END
625     LPX* lp;
626
627     check_LPX(lpx);
628     if (!(j >= 0))
629     {
630       chicken_LPX_exception (ERR_NEG_IND, 37, "column index must be zero or positive");
631     }
632
633     lp = LPX_val(lpx);
634
635     lpx_set_col_bnds (lp, j, typx, lb, ub);
636
637     C_return(lpx);
638END
639))     
640
641(define (lpx_set_bounds label f_set_bounds)
642  (lambda (lpx i typx . rest)
643    (let-optionals rest ((b1 #f) (b2 #f))
644      (case typx 
645        ((free unbounded)  (f_set_bounds lpx i LPX_FR 0 0))
646        ((lower-bound lower lo lb) 
647         (if (integer? b1)
648             (f_set_bounds lpx i LPX_LO b1 0)
649             (error label "lower bound argument must be an integer")))
650        ((upper-bound upper up ub) 
651         (if (integer? b1)
652             (f_set_bounds lpx i LPX_UP 0 b1)
653             (error label "upper bound argument must be an integer")))
654        ((double-bounded double db) 
655         (if (and (integer? b1) (integer? b2))
656             (f_set_bounds lpx i LPX_DB b1 b2)
657             (error label "lower and upper bound arguments must be integers")))
658        ((fixed fx) 
659         (if (and (integer? b1) (integer? b2))
660             (f_set_bounds lpx i LPX_FX b1 b2)
661             (error label "lower and upper bound arguments must be integers")))
662        (else (error label "invalid bound type" typx))))))
663     
664(define lpx:set-row-bounds     (lpx_set_bounds 'lpx:set-row-bounds lpx_set_row_bounds))
665(define lpx:set-column-bounds  (lpx_set_bounds 'lpx:set-column-bounds lpx_set_col_bounds))
666
667(define lpx_get_column_primals
668    (foreign-lambda* void ((scheme-object lpx)
669                           (int n)
670                           (f64vector v)
671                           )
672#<<END
673     LPX* lp;  int j;
674
675     check_LPX(lpx);
676
677     lp = LPX_val(lpx);
678
679     for (j = 1; j <= n; j++)
680       v[j-1] = lpx_get_col_prim (lp, j);
681
682     C_return(C_SCHEME_UNDEFINED);
683END
684))     
685
686
687(define lpx:get-objective-value
688    (foreign-lambda* double ((scheme-object lpx)
689                           )
690#<<END
691     LPX* lp;  double result;
692
693     check_LPX(lpx);
694
695     lp = LPX_val(lpx);
696
697     result = lpx_get_obj_val (lp);
698
699     C_return(result);
700END
701))     
702     
703(define (lpx:get-column-primals lpx)
704  (let* ((n (lpx:get-num-columns lpx))
705         (v (make-f64vector n 0)))
706    (lpx_get_column_primals lpx n v)
707    v))
708
709
710(define lpx:set-objective-coefficient 
711    (foreign-lambda* scheme-object ((scheme-object lpx)
712                                    (int j)
713                                    (double coef) 
714                                    )
715#<<END
716     LPX* lp;
717
718     check_LPX(lpx);
719     if (!(j >= 0))
720     {
721       chicken_LPX_exception (ERR_NEG_IND, 37, "column index must be zero or positive");
722     }
723
724     lp = LPX_val(lpx);
725
726     lpx_set_obj_coef (lp, j, coef);
727
728     C_return(lpx);
729END
730))     
731
732
733
734(define LPX_CV   (foreign-value "LPX_CV" int))
735(define LPX_IV   (foreign-value "LPX_IV" int))
736
737(define lpx_set_column_kind 
738    (foreign-lambda* scheme-object ((scheme-object lpx)
739                                    (int j)
740                                    (int kind) 
741                                    )
742#<<END
743     LPX* lp;
744
745     check_LPX(lpx);
746     if (!(j >= 0))
747     {
748       chicken_LPX_exception (ERR_NEG_IND, 37, "column index must be zero or positive");
749     }
750     if (!((kind == LPX_CV) || (kind == LPX_IV)))
751     {
752       chicken_LPX_exception (ERR_INVALID_COL_KIND, 23, "invalid LPX column kind");
753     }
754
755     lp = LPX_val(lpx);
756
757     lpx_set_col_kind (lp, j, kind);
758
759     C_return(lpx);
760END
761))     
762
763(define (lpx:set-column-kind lpx j kind)
764  (case kind
765    ((integer int iv) (lpx_set_column_kind lpx j LPX_IV))
766    ((continuous cont cv) (lpx_set_column_kind lpx j LPX_CV))
767    (else (error 'lpx:set-column-kind "invalid column kind" kind))))
768
769
770(define lpx_load_constraint_matrix 
771    (foreign-lambda* scheme-object ((scheme-object lpx)
772                                    (int nrows)
773                                    (int ncols)
774                                    (char order)
775                                    (f64vector m)
776                                    (s32vector ia)
777                                    (s32vector ja)
778                                    (f64vector ar)
779                                    )
780#<<END
781     int i,j,k;
782     double x;
783     LPX* lp;
784
785     check_LPX(lpx);
786     k = 1;
787
788     // row-major
789     if ((order == 'r') || (order == 'R'))
790     {
791       for (i = 0; i < nrows; i++)
792       {
793          for (j = 0; j < ncols; j++)
794          {
795               x = m[(i*ncols)+j];
796               if (x != 0)
797               {
798                    ia[k]  = i+1;
799                    ja[k]  = j+1;
800                    ar[k]  = x;
801                    k++;
802               }
803          }
804       }
805     // column-major
806     } else if ((order == 'c') || (order == 'C'))
807       {
808        for (j = 0; j < ncols; j++)
809        {
810          for (i = 0; i < nrows; i++)
811          {
812               x = m[(j*nrows)+i];
813               if (x != 0)
814               {
815                    ia[k]  = i+1;
816                    ja[k]  = j+1;
817                    ar[k]  = x;
818                    k++;
819               }
820          }
821        }
822       } else
823       {
824         chicken_LPX_exception (ERR_INVALID_MAT_ORD, 35, "invalid LPX constraint matrix order");
825       }
826   
827       lp = LPX_val(lpx);
828       lpx_load_matrix(lp, k-1, ia, ja, ar);
829
830
831     C_return(lpx);
832END
833))     
834
835(define (lpx:load-constraint-matrix lpx m nrows ncols . rest)
836  (let-optionals rest ((order 'row-major))
837    (if (not (positive? nrows)) (error 'lpx:load-constraint-matrix "nrows must be positive"))
838    (if (not (positive? ncols)) (error 'lpx:load-constraint-matrix "ncols must be positive"))
839    (let ((ia (make-s32vector nrows 0))
840          (ja (make-s32vector ncols 0))
841          (ar (make-f64vector (* ncols nrows) 0))
842          (oc (case order
843                ((row row-major)  #\r)
844                ((col column col-major column-major)  #\c)
845                (else (error 'lpx:load-constraint-matrix "invalid constraint matrix order")))))
846      (lpx_load_constraint_matrix lpx nrows ncols oc m ia ja ar))))
847
848
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) */
864
865
866(define lpx:simplex 
867    (foreign-lambda* int ((scheme-object lpx)) 
868                                   
869#<<END
870     int status;
871     LPX* lp;
872
873     check_LPX(lpx);
874
875     lp = LPX_val(lpx);
876
877     status = lpx_simplex (lp);
878
879     C_return(status);
880END
881))     
882
883
884(define lpx:integer 
885    (foreign-lambda* int ((scheme-object lpx)) 
886                                   
887#<<END
888     int status;
889     LPX* lp;
890
891     check_LPX(lpx);
892
893     lp = LPX_val(lpx);
894
895     status = lpx_integer (lp);
896
897     C_return(status);
898END
899))     
900
901
902(define lpx:scale-problem 
903    (foreign-lambda* scheme-object ((scheme-object lpx)) 
904                                   
905#<<END
906     LPX* lp;
907
908     check_LPX(lpx);
909
910     lp = LPX_val(lpx);
911
912     lpx_scale_prob (lp);
913
914     C_return(lpx);
915END
916))     
917
918
919(define (lpx:make-problem dir pbounds xbounds objcoefs constraints . rest)
920  (let-optionals rest ((m-order 'row-major))
921   (let* ((lpx    (lpx:empty-problem))
922          (lpx    (lpx:set-direction lpx dir ))
923          (nrows  (length pbounds ))
924          (ncols  (length xbounds ))
925          (lpx    (lpx:add-rows lpx nrows ))
926          (lpx    (lpx:add-columns lpx ncols )))
927     (fold (lambda (pi i)
928             (apply lpx:set-row-bounds (cons* lpx i pi))
929             (+ 1 i))
930           1 pbounds)
931     (fold (lambda (xi ci i)
932             (lpx:set-objective-coefficient lpx i ci)
933             (apply lpx:set-column-bounds (cons* lpx i xi))
934             (+ 1 i))
935           1 xbounds objcoefs)
936     (let ((lpx (lpx:load-constraint-matrix lpx constraints nrows ncols m-order)))
937       lpx))))
938
939)
Note: See TracBrowser for help on using the repository browser.