source: project/release/3/glpk/trunk/glpk.scm @ 10749

Last change on this file since 10749 was 10749, checked in by Ivan Raikov, 12 years ago

Created initial release.

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